C********** Fixheader - fix eof markers for files-11 files ********** C C VICKI W. WOOLF C PROGRAM OF COMPUTER GRAPHICS - CORNELL UNIVERSITY C 120 RAND HALL ITHACA NEW YORK 14853 (607) 256-7444 C C modified January 1982 by C LES TABATA C COMPUTER SCIENCE AND MATHEMATICS C LAWRENCE BERKELEY LAB C BERKELEY, CA 94720 (415) 486-5766 C C FIXHEADER is a tool that allows a user to examine the C header blocks and data blocks of a file. It also allows C the user to change the EOF marker. C C The January 1982 modifications will allow the user to find C the file that contains a given logical block number, by C reading all file headers and extracting all map pointer C information. C Logical block numbers can be specified explicitly or by C cylinder, track, and sector number. The following values C will allow correct logical block number calculation C from cylinder, track, and sector information for an RM05. C Alternate C/T/S information may be found in the I/O User's C Guide in the disk drivers chapter. This information may be C changed online by specifying a LBN of -2. C INTEGER*4 SECPERTRK,TRKPERCYL CHARACTER*4 DISKTYPE,LDISKTYPE DATA SECPERTRK,TRKPERCYL/32,19/ DATA DISKTYPE/'RM05'/ EXTERNAL SS$_NORMAL,SS$_NOTRAN,SS$_NOPRIV ! Global 1 ,IO$_WRITELBLK,IO$_READLBLK 2 ,IO$_READVBLK,IO$_ACCESS,IO$_DEACCESS 3 ,IO$M_ACCESS INTEGER*4 SS$_NORMAL,SS$_NOTRAN,SS$_NOPRIV 1 ,IO$_WRITELBLK,IO$_READLBLK 2 ,IO$_READVBLK,IO$_ACCESS,IO$_DEACCESS 3 ,IO$M_ACCESS INTEGER*4 SYS$ASSIGN,SYS$TRNLOG,SYS$DASSGN,SYS$QIOW INTEGER*4 VW$GET_FID PARAMETER ATR$S_RECATTR = '00000020'X 1 ,ATR$C_RECATTR = '00000004'X 2 ,ATR$S_ASCNAME = '00000014'X 3 ,ATR$C_ASCNAME = '00000010'X C********** Explanation of local variables ********** C C********** Buffer areas ********** C C These all map to the same 512 bytes. C C HEADER = Buffer for file headers. C BUFFER = Temporary buffer. C HOME_BLOCK = Buffer for home block. C DATA_BLOCK = Buffer for file data blocks. BYTE HEADER_B(0:511),HOME_BLOCK(0:511) BYTE DIRHEADER_B(0:511) INTEGER*2 HEADER_W(0:255),DIRBLK INTEGER*4 HEADER(0:127),BUFFER(0:127) INTEGER*4 DATA_BLOCK(0:127) CHARACTER*512 BUFFER_C EQUIVALENCE (HEADER,HEADER_B,HEADER_W) EQUIVALENCE (HEADER,HOME_BLOCK,BUFFER,DATA_BLOCK) EQUIVALENCE (HEADER_B,BUFFER_C) C********** File header variables ********** C C H$MAPPTR = Ptr to map pointers in file header. C H$FNUM = File identifier. C H$FSEQ C H$FRVN C H$EXTNO = If this is nonzero, it points to the next block C of the file header. C H$NO_MAPWORD = Number of words allocated for map pointers in C this block of the file header. C H$GRPNUM = UIC. C H$MEMNUM C H$BPTR = Back pointer to id of directory file containing the C current file. C D$BPTR = Back pointer to id of directory fiel containing the C current directory file. C D$DIRNAME = Name of back-pointed directory in header C C Map pointer formats: (See diagram below). C FORMAT0 = 2 byte placement word C FORMAT1 = 4 byte map word C FORMAT2 = 6 byte map word. C FORMAT3 = 8 byte map word. C C File attributes (in file header). C RECATTR = buffer for file attributes - (this will be used to C update header in QIOW. C R$ALLOC = blocks allocated to a file C R$EOF = block number that is eof. C R$FREE = first byte available in R$EOF block. C C File name (in file header). C NOTE: C This is the original name of the file. If you rename a file C the new name is not stored here. It only appears in the directory C file. C ASCNAME = name of file in file header. BYTE H$MAPPTR INTEGER*2 H$FNUM,H$FSEQ,H$FRVN,H$EXTNO,H$NO_MAPWORD INTEGER*2 H$GRPNUM,H$MEMNUM,H$BPTR INTEGER*2 D$BPTR,D$DIRLEN CHARACTER*13 D$DIRNAME EQUIVALENCE (H$FNUM,HEADER_B(8)),(H$FSEQ,HEADER_B(10)) 1 ,(H$FRVN,HEADER_B(12)),(H$EXTNO,HEADER_B(14)) 2 ,(H$MAPPTR,HEADER_B(1)),(H$NO_MAPWORD,HEADER_B(58)) 3 ,(H$MEMNUM,HEADER_B(60)),(H$GRPNUM,HEADER_B(62)) 4 ,(H$BPTR,HEADER_B(66)) EQUIVALENCE (D$BPTR,DIRHEADER_B(66)) 1 ,(D$DIRNAME,DIRHEADER_B(76)) BYTE FORMAT0,FORMAT1,FORMAT2,FORMAT3 DATA FORMAT0,FORMAT1,FORMAT2,FORMAT3 1 / '00'X ,'40'X, '80'X, 'C0'X / INTEGER*2 FORMAT2_W,FORMAT3_W DATA FORMAT2_W,FORMAT3_W 1 / '8000'X, 'C000'X / BYTE RECATTR(32) INTEGER*2 R$ALLOC,R$EOF,R$FREE EQUIVALENCE (R$ALLOC,RECATTR(7)),(R$EOF,RECATTR(11)) 1 ,(R$FREE,RECATTR(13)) INTEGER*4 RL$ALLOC,RL$EOF,RL$FREE BYTE ASCNAME(20) CHARACTER*20 ASCNAME_C EQUIVALENCE (ASCNAME,ASCNAME_C) CHARACTER*80 PATHNAME INTEGER*2 PATHLEN,PATHX C********** Home block variables. ********** C C H$IBSZ = size of bitmap in blocks. C H$SBCL = cluster size of device. INTEGER*2 HB$IBSZ,HB$SBCL EQUIVALENCE (HB$IBSZ,HOME_BLOCK(32)),(HB$SBCL,HOME_BLOCK(14)) INTEGER*2 HOME_BLOCK_NO DATA HOME_BLOCK_NO /2/ C********** FIB - file information block variables ********** C C FIB_DESCR = character string descriptor used to point at FIB. C FIB_BUFF = buffer used for FIB. C FIB$W_FID_NUM= file id. C FIB$W_FID_SEQ C FIB$W_FID_RVN C FIB$W_DID_NUM= directory file id. C FIB$W_DID_SEQ C FIB$W_DID_RVN C FIB$W_NMCTL = sets up search criteria used by ACP. C FIB$L_ACCTL = Access control longword. C FIB$B_WSIZE = INTEGER*4 FIB_DESCR(2) INTEGER*2 FIB_DESCR_W(4) EQUIVALENCE (FIB_DESCR,FIB_DESCR_W) PARAMETER FIB$M_WRITE = '00000100'X INTEGER*2 FIB$W_FID_NUM,FIB$W_FID_SEQ,FIB$W_FID_RVN,FIB$W_NMCTL INTEGER*2 FIB$W_DID_NUM,FIB$W_DID_SEQ,FIB$W_DID_RVN INTEGER*4 FIB$L_ACCTL BYTE FIB$B_WSIZE,FIB_BUFF(0:43) EQUIVALENCE (FIB$L_ACCTL,FIB_BUFF(0)),(FIB$B_WSIZE,FIB_BUFF(3)) 1 ,(FIB$W_FID_NUM,FIB_BUFF(4)) 2 ,(FIB$W_FID_SEQ,FIB_BUFF(6)) 3 ,(FIB$W_FID_RVN,FIB_BUFF(8)) 4 ,(FIB$W_DID_NUM,FIB_BUFF(10)) 5 ,(FIB$W_DID_SEQ,FIB_BUFF(12)) 6 ,(FIB$W_DID_RVN,FIB_BUFF(14)) 7 ,(FIB$W_NMCTL,FIB_BUFF(20)) C********** QIO variables ********** C C IOSB = I/O status block - this is filled when I/O completes. C ATRIB_LIST = list of requests to ACP. C ICHAN = I/O channel assigned to file - used by ACP. BYTE IOSB_B(8) INTEGER*2 IOSB_W(4) INTEGER*4 IOSB(2) EQUIVALENCE (IOSB,IOSB_B,IOSB_W) INTEGER*4 ATRIB_LIST(10) INTEGER*2 ATRIB_LIST_W(20) EQUIVALENCE (ATRIB_LIST,ATRIB_LIST_W) INTEGER*2 ICHAN C********** other local variables ********* C C STATUS = status longword. C LU_INDEX = logical unit number assigned to INDEXF.SYS C INPUT = logical unit number assigned to SYS$INPUT C OUTPUT = logical unit number assigned to SYS$OUTPUT C MAP = map pointers for file (1st col:#blocks,2nd col:begin LBN C NAMEBUF = buffer and length used for file name. C NAMELEN C DISK = buffer used for disk name. C DISKLEN C FULL_FILENAM = buffer and length of full filespec returned by VW$GET_FID. C FULL_FILELEN C RESP = buffers for receiving user input. C LONGRESP C TEMP_STRIN = temporary buffer. C FILID,FILEID = file identifier (used to access INDEXF.SYS) C DIRID = directory file identifier. C GRPNUM,MEMNUM= UIC. C ISTART_BLOCK = block number in INDEXF.SYS that marks the beginning of C file headers. C EXT_FLAG = Flag used to indicate multi-block file header. C NUM_HEADER_BLKS= Number of blocks in file header. C INDEXX = Total number of map pointers in file header. C FILEID_STRING= Used for displaying only. C BLOCK_STRING C OWNER_STRING C COUNTER,IEND,I,M,VBN,ILBN,VBN,INCPTR,PTR,TOT_COUNT,TOT_MAPWORD C = Temporary variables. INTEGER*4 LU_INDEX,INPUT,OUTPUT DATA LU_INDEX,INPUT,OUTPUT /1,2,3/ INTEGER*4 MAP(2,1024) INTEGER*4 ICOUNT,LBN,NUM_MAPWORDS INTEGER*2 ICOUNT_W(2),LBN_W(2) BYTE ICOUNT_B(4),LBN_B(4),NUM_MAPWORDS_B(4) EQUIVALENCE (ICOUNT,ICOUNT_W,ICOUNT_B) EQUIVALENCE (LBN,LBN_W,LBN_B) EQUIVALENCE (NUM_MAPWORDS,NUM_MAPWORDS_B) INTEGER*2 NAMELEN CHARACTER*112 NAMEBUF,FULL_FILENAM INTEGER*4 FULL_FILELEN CHARACTER*1 RESP,LONGRESP*16 CHARACTER*80 TEMP_STRING CHARACTER*6 DISK INTEGER*2 DISKLEN INTEGER*2 FILID(3),DIRID(3) INTEGER*2 FILEID,GRPNUM,MEMNUM EQUIVALENCE (FILEID,FILID) INTEGER*4 NEW_USED,NEW_FREE,VBN,ILBN,HBN INTEGER*4 ISTART_BLOCK LOGICAL*1 EXT_FLAG INTEGER*4 COUNTER,IEND,I,M,FILBLK,STATUS,INCPTR INTEGER*4 INDEXX,TOT_COUNT,PTR,TOT_MAPWORD,NUM_HEADER_BLKS BYTE FORMAT_TYPE CHARACTER FILEID_STRING*15,BLOCK_STRING*13,OWNER_STRING*9 C********** File inversion variables ********** C C INVERTID = contains the file seq.no. for this extent ptr C INVERTPTR = (*,1) contains the starting LBN, (*,2) contains the C extent for this ptr C INVERTLBN = the LBN to search for C INVPT = a pointer into the arrays C MARKER = the total number of file extent pointers C CYL,TRK,SEC = for converting C,T,S numbers into LBN C INTEGER*2 INVERTID(400000) INTEGER*4 INVERTPTR(400000,2) INTEGER*4 INVPT,MARKER INTEGER*4 INVERTLBN DATA MARKER/0/ CHARACTER*1 VERIF,CYLTRKSEC INTEGER*4 CYL,TRK,SEC C********** Called functions ********** C C LENGTH = returns length of string. C NCODE = does an encode on the input number. C CAPITALIZE = converts string from lower to upper case. C STRIP_BLANKS = removes all blanks from input string. C ZERO_FILL = converts all blanks to zeroes. INTEGER*4 LENGTH CHARACTER*8 NCODE CHARACTER*112 CAPITALIZE CHARACTER*14 STRIP_BLANKS CHARACTER*14 ZERO_FILL C********** Initialization ********** C C >Assign unit numbers to SYS$INPUT and SYS$OUTPUT for fortran I/O. C >Type out program heading. C >Prompt user to enter default disk name C >For first pass, set filename to [0,0]indexf.sys. C >For first pass, skip next two items. C >Entry point from main loop. C >Prompt user to input file name or file id. C >If EOF mark, then branch to cleanup. C >Capitalize the input string. C >If user types ID= C >Verify that id number is a valid integer. C >If not, loop back to prompt. C >Request user to enter disk name. C >If none entered, assume the default disk. C >If string entered, then. C >Capitalize input string. C >If the ":" was omitted, then append to string. C >If user does not type ID= C >Get file id. C >If invalid filespec, loop back to prompt. C >Open index file on requested disk. C >Read in home block (contains cluster size and bitmap size. C >Calculate starting block number (4*cluster+bitmap) OPEN(UNIT=OUTPUT,NAME='SYS$OUTPUT',STATUS='UNKNOWN') OPEN(UNIT=INPUT,NAME='SYS$INPUT',STATUS='UNKNOWN') WRITE(OUTPUT,7000) WRITE(OUTPUT,7601) READ(INPUT,7020) DISKLEN,DISK NAMEBUF(1:DISKLEN) = DISK(1:DISKLEN) NAMELEN = DISKLEN IF (INDEX(NAMEBUF(1:NAMELEN),':') .LE. 0) THEN NAMEBUF(NAMELEN+1:) = ':' NAMELEN = NAMELEN + 1 ENDIF NAMEBUF(1:NAMELEN+15) = NAMEBUF(1:NAMELEN)//'[0,0]INDEXF.SYS' NAMELEN = NAMELEN + 15 GOTO 11 10 WRITE(OUTPUT,7010) READ(INPUT,7020,END=1010)NAMELEN,NAMEBUF IF (NAMELEN .LE. 0) GOTO 10 11 NAMEBUF = CAPITALIZE(NAMEBUF) IF (INDEX(NAMEBUF(1:NAMELEN),'ID=') .NE. 0) THEN TEMP_STRING = NAMEBUF(INDEX(NAMEBUF,'ID=')+3:) DECODE(LENGTH(TEMP_STRING),7030,TEMP_STRING,ERR=10)FILEID WRITE(OUTPUT,7300)DISK(1:DISKLEN) READ(INPUT,7070,END=10)TEMP_STRING TEMP_STRING = CAPITALIZE(TEMP_STRING) IF (LENGTH(TEMP_STRING) .GT. 0) THEN DISK = TEMP_STRING DISKLEN = LENGTH(TEMP_STRING) IF (INDEX(DISK(1:DISKLEN),':') .LE. 0)THEN DISK(DISKLEN+1:) = ':' DISKLEN = LENGTH(DISK) ENDIF ENDIF ELSE DO 13 I = 0,127 13 BUFFER(I) = 0 STATUS = VW$GET_FID(BUFFER,NAMEBUF(1:NAMELEN),FULL_FILENAM 1 ,FULL_FILELEN,DIRID,FILID) IF (.NOT.STATUS) THEN WRITE(OUTPUT,7320) GOTO 10 ENDIF DISK = FULL_FILENAM(1:INDEX(FULL_FILENAM,':')) DISKLEN = LENGTH(DISK) ENDIF OPEN(UNIT=LU_INDEX,NAME=DISK(1:DISKLEN)//'[0,0]INDEXF.SYS' 1 ,ORGANIZATION='SEQUENTIAL',ACCESS='DIRECT' 2 ,READONLY,SHARED,TYPE='OLD',FORM='UNFORMATTED' 3 ,RECORDTYPE='FIXED',RECORDSIZE=128,ERR=810) READ (LU_INDEX'HOME_BLOCK_NO,ERR=800) HOME_BLOCK ISTART_BLOCK = HB$SBCL*4 + HB$IBSZ C********** Initialization for requested file ********** C C >Calculate block number of header file (ISTART_BLOCK + FILEID) C >Read in first header block for file. C >Test to see if file is a multi-header file. C >If true, then set flag. C >Test to see if this is block 1 of the file. C >If not, then this is an invalid request,type message,loop to start. C >Build FIB (file information block). C >Build FIB descriptor block. C >Build attribute list. C >Assign a channel to the disk in order to logical IO. C >If fail, report error and stop. C >Access file. C >If fail, report error and stop. C >Initialize counter into MAP array. C >For each header block. C >Initialize PTR into header to point to mapwords. C >Initialize mapwords counter (NUM_MAPWORDS) C >For each mapword. C >Get format type of mapword. C >If type .eq. format0 (placement word-ignore for now.) C >Increment mapwords counter by 2. C >If type .eq. format1 (four byte mapword). C |--|-------|----------| C |01| High | Count | C |--|-------|----------| C | Low Order LBN | C |---------------------| C >If type .eq. format2 (six byte mapword). C |--|-------|----------| C |02| Count | C |--|-------|----------| C | | C |- LBN -| C | | C |---------------------| C >If type .eq. formtat3 (eight byte mapword). C |--|------------------| C |03| High | C |--|------------------| C | Low Order Count | C |---------------------| C | | C |- LBN -| C | | C |---------------------| C >(end of mapword). C >Store LBN and COUNT into MAP array. C >Increment pointer in header. C >(end of headers). C >Close index file. C >Set up command to be 'G' (general info) - branch into main loop. FILBLK = FILEID + ISTART_BLOCK READ(LU_INDEX'FILBLK,ERR=800) HEADER EXT_FLAG = .FALSE. IF (H$EXTNO .NE. 0) EXT_FLAG = .TRUE. IF (H$SEGNO .NE. 0) THEN WRITE(OUTPUT,7040) GOTO 10 ENDIF FIB$W_FID_NUM = H$FNUM FIB$W_FID_SEQ = H$FSEQ FIB$W_FID_RVN = H$FRVN FIB$L_ACCTL = FIB$M_WRITE FIB$B_WSIZE = 0 FIB$W_NMCTL = 0 FIB$W_DID_NUM = 0 FIB$W_DID_SEQ = 0 FIB$W_DID_RVN = 0 FIB_DESCR_W(1) = 22 FIB_DESCR(2) = %LOC(FIB_BUFF) ATRIB_LIST_W(1) = ATR$S_RECATTR ATRIB_LIST_W(2) = ATR$C_RECATTR ATRIB_LIST(2) = %LOC(RECATTR) ATRIB_LIST_W(5) = ATR$S_ASCNAME ATRIB_LIST_W(6) = ATR$C_ASCNAME ATRIB_LIST(4) = %LOC(ASCNAME) ATRIB_LIST(5) = 0 STATUS = SYS$ASSIGN(DISK(1:DISKLEN),ICHAN,%VAL(3),) IF (STATUS .NE. %LOC(SS$_NORMAL)) THEN CALL FIX_REPORT('Error during ASSIGN '''//NCODE(STATUS) 1 //'''X') GOTO 1010 ENDIF STATUS = SYS$QIOW(,%VAL(ICHAN) 1 ,%VAL(%LOC(IO$_ACCESS).OR.%LOC(IO$M_ACCESS)) 2 ,IOSB,,,FIB_DESCR,,NAMELEN,NAMEBUF,ATRIB_LIST,) IF (STATUS.NE.%LOC(SS$_NORMAL) .OR. IOSB_W(1).NE.%LOC(SS$_NORMAL))THEN IF (IOSB_W(1) .EQ. %LOC(SS$_NOPRIV)) THEN WRITE (OUTPUT,7330) GOTO 10 ENDIF CALL FIX_REPORT('Error during ACCESS ''' 1 //NCODE(IOSB_W)//'''X') GOTO 1005 ENDIF GRPNUM = H$GRPNUM MEMNUM = H$MEMNUM INDEXX = 0 TOT_COUNT = 0 40 MAPP = H$MAPPTR PTR = MAPP*2 NUM_MAPWORDS = 0 NUM_MAPWORDS_B(1) = H$NO_MAPWORD NUM_MAPWORDS = NUM_MAPWORDS * 2 TOT_MAPWORD = 0 NUM_HEADER_BLKS = 1 50 FORMAT_TYPE = HEADER_B(PTR+1) .AND. 'C0'X IF (FORMAT_TYPE .EQ. FORMAT0) THEN ICOUNT = 0 LBN = 0 INCPTR = 2 ELSEIF (FORMAT_TYPE .EQ. FORMAT1) THEN ICOUNT = 0 ICOUNT_B(1) = HEADER_B(PTR) LBN_B(4) = 0 LBN_B(3) = HEADER_B(PTR+1) .AND. '3F'X LBN_B(2) = HEADER_B(PTR+3) LBN_B(1) = HEADER_B(PTR+2) INCPTR = 4 ELSEIF (FORMAT_TYPE .EQ. FORMAT2) THEN ICOUNT = HEADER_W((PTR+1)/2) .AND. '3FFF'X LBN_W(1) = HEADER_W((PTR+1)/2 + 1) LBN_W(2) = HEADER_W((PTR+1)/2 + 2) INCPTR = 6 ELSEIF (FORMAT_TYPE .EQ. FORMAT3) THEN ICOUNT_W(2) = HEADER_W((PTR+1)/2) .AND. '3FFF'X ICOUNT_W(1) = HEADER_W((PTR+1)/2 + 1) LBN_W(1) = HEADER_W((PTR+1)/2 + 2) LBN_W(2) = HEADER_W((PTR+1)/2 + 3) INCPTR = 8 ENDIF IF (ICOUNT .GT. 0) ICOUNT = ICOUNT + 1 TOT_COUNT = TOT_COUNT + ICOUNT INDEXX = INDEXX + 1 MAP(1,INDEXX) = ICOUNT MAP(2,INDEXX) = LBN PTR = PTR + INCPTR TOT_MAPWORD = TOT_MAPWORD + INCPTR IF (TOT_MAPWORD .LT. NUM_MAPWORDS) GOTO 50 IF (EXT_FLAG) THEN FILBLK = H$EXTNO + ISTART_BLOCK READ(LU_INDEX'FILBLK,ERR=800) HEADER IF (H$EXTNO .EQ. 0) EXT_FLAG = .FALSE. NUM_HEADER_BLKS = NUM_HEADER_BLKS + 1 GOTO 40 ENDIF CLOSE (UNIT=1) RESP = 'G' GOTO 58 C********** Program loop ********** C C >Prompt user for command. C >Capitalize input string. 55 WRITE(OUTPUT,7060) READ(INPUT,7070,END=1000)RESP RESP = CAPITALIZE(RESP) C********** V - Examine Virtual block ********** C C >Loop: C >Request user to enter virtual block number. C >If ^Z or virtual block number is less than 0, branch to main loop. C >If virtual block number is greater than allocated blocks C >Type message. C >Go back to loop. C >Issue a virtual QIO. C >If not successful, C >Type error message. C >Go back to loop. C >Display virtual block. 58 IF (RESP .EQ. 'V') THEN 60 WRITE(OUTPUT,7080) READ(INPUT,7070,END=55)LONGRESP DECODE(LENGTH(LONGRESP),7090,LONGRESP,ERR=60)VBN IF (VBN .LE. 0) GOTO 55 IF (VBN .GT. R$ALLOC) THEN WRITE(OUTPUT,7100) GOTO 60 ENDIF STATUS = SYS$QIOW(,%VAL(ICHAN),IO$_READVBLK,IOSB,,, 1 DATA_BLOCK,%VAL(512),%VAL(VBN),,,) IF (STATUS .NE. %LOC(SS$_NORMAL) 1 .OR. IOSB_W(1) .NE. %LOC(SS$_NORMAL)) THEN WRITE(OUTPUT,7110)STATUS,IOSB_W(1) GOTO 55 ENDIF CALL DUMPIT(OUTPUT,DATA_BLOCK) GOTO 60 C********** L - Examine logical block ********** C C >Loop: C >Request user to enter logical block number. C >If ^Z, branch to main loop. C >If logical block number does not exist in MAP. C >Type message. C >Go back to loop. C >Issue a logical QIO. C >If not successful, C >Type error message. C >Go back to loop. C >Display logical block ELSEIF (RESP .EQ. 'L') THEN 70 WRITE(OUTPUT,7120) READ(INPUT,7070,END=55)LONGRESP DECODE(LENGTH(LONGRESP),7090,LONGRESP,ERR=70)ILBN IF (ILBN .LE. 0) GOTO 55 DO 80 COUNTER = 1,INDEXX IF (ILBN .GE. MAP(2,COUNTER) 1 .AND. ILBN .LT. MAP(2,COUNTER)+MAP(1,COUNTER))GOTO 85 80 CONTINUE WRITE(OUTPUT,7130) GOTO 70 85 STATUS = SYS$QIOW(,%VAL(ICHAN),IO$_READLBLK,IOSB,,, 1 DATA_BLOCK,%VAL(512),%VAL(ILBN),,,) IF (STATUS .NE. %LOC(SS$_NORMAL) 1 .OR. IOSB_W(1) .NE. %LOC(SS$_NORMAL)) THEN IF (STATUS .EQ. %LOC(SS$_NOPRIV)) THEN WRITE(OUTPUT,7110) ELSE CALL FIX_REPORT('Error in logical I/O - ''' 1 //NCODE(STATUS)//'''X ''' 2 //NCODE(IOSB)//'''X') ENDIF GOTO 55 ENDIF CALL DUMPIT(OUTPUT,DATA_BLOCK) GOTO 70 C********** G - Display general information ********** C C >Open index file. C >Gather directory path by following header back pointers to directory C headers and extracting their names and their back pointers. C Don't do this more than 8 times in case path gets lost. C >Close index file. C >Display general file information. C >Go back to main loop. ELSEIF (RESP .EQ. 'G') THEN ENCODE(15,7270,FILEID_STRING)FILID FILEID_STRING = STRIP_BLANKS(FILEID_STRING) RL$EOF = R$EOF RL$ALLOC = R$ALLOC RL$FREE = R$FREE RL$EOF = RL$EOF .AND. 'FFFF'X RL$ALLOC = RL$ALLOC .AND. 'FFFF'X RL$FREE = RL$FREE .AND. 'FFFF'X NEW_EOF = RL$EOF IF (RL$EOF.EQ.RL$ALLOC+1 .AND. RL$FREE.EQ.0)NEW_EOF=RL$EOF-1 ENCODE(13,7280,BLOCK_STRING)NEW_EOF,RL$ALLOC BLOCK_STRING=STRIP_BLANKS(BLOCK_STRING) ENCODE(9,7290,OWNER_STRING)GRPNUM,MEMNUM OWNER_STRING=ZERO_FILL(OWNER_STRING) PATHNAME(1:2) = '[]' PATHLEN = 2 DIRBLK = ISTART_BLOCK + H$BPTR OPEN(UNIT=LU_INDEX,NAME=DISK(1:DISKLEN)//'[0,0]INDEXF.SYS' 1 ,ORGANIZATION='SEQUENTIAL',ACCESS='DIRECT' 2 ,READONLY,SHARED,TYPE='OLD',FORM='UNFORMATTED' 3 ,RECORDTYPE='FIXED',RECORDSIZE=128,ERR=810) DO 87 II=1,8 READ (LU_INDEX'DIRBLK,ERR=800) DIRHEADER_B D$DIRLEN = INDEX (D$DIRNAME,'.') PATHNAME(2:PATHLEN+D$DIRLEN) = 1 D$DIRNAME(1:D$DIRLEN)//PATHNAME(2:PATHLEN) PATHLEN = PATHLEN + D$DIRLEN IF (D$BPTR.EQ.4 .AND. 1 D$DIRNAME(1:D$DIRLEN).EQ.'000000.') THEN PATHX = INDEX (PATHNAME,']') PATHNAME(1:PATHLEN-1) = PATHNAME(1:PATHX-2)// 1 PATHNAME(PATHX:PATHLEN) PATHLEN = PATHLEN -1 GOTO 88 ELSE DIRBLK = ISTART_BLOCK + D$BPTR ENDIF 87 CONTINUE 88 CLOSE (UNIT=LU_INDEX) IF (RL$EOF .EQ. RL$ALLOC+1 .AND. RL$FREE .EQ. 0) THEN WRITE(OUTPUT,7051)ASCNAME_C(1:LENGTH(ASCNAME_C)) 1 ,PATHNAME(1:PATHLEN),ASCNAME_C(1:LENGTH(ASCNAME_C)) 2 ,FILEID_STRING,BLOCK_STRING 3 ,OWNER_STRING,NUM_HEADER_BLKS,INDEXX ELSE WRITE(OUTPUT,7050)ASCNAME_C(1:LENGTH(ASCNAME_C)) 1 ,PATHNAME(1:PATHLEN),ASCNAME_C(1:LENGTH(ASCNAME_C)) 2 ,FILEID_STRING,BLOCK_STRING,RL$FREE 3 ,OWNER_STRING,NUM_HEADER_BLKS,INDEXX ENDIF GOTO 55 C********** H - Examine header block ********** C C >Open index file. C >Loop: C >Request user to enter header block number. C >If header block number exceeds maximum number of C header blocks. C >Type message. C >Go back to loop. C >If header block number valid, C >Cycle through headers until the requested header is found. C >Display header C >Go back to loop. C >If ^Z or input value is less than or equal to 0. C >Close index file. C >Go back to main loop. ELSEIF (RESP .EQ. 'H') THEN OPEN(UNIT=LU_INDEX,NAME=DISK(1:DISKLEN)//'[0,0]INDEXF.SYS' 1 ,ORGANIZATION='SEQUENTIAL',ACCESS='DIRECT' 2 ,READONLY,SHARED,TYPE='OLD',FORM='UNFORMATTED' 3 ,RECORDTYPE='FIXED',RECORDSIZE=128,ERR=810) 90 WRITE(OUTPUT,7140) READ(INPUT,7070,END=55)LONGRESP DECODE(LENGTH(LONGRESP),7090,LONGRESP,ERR=70)HBN IF (HBN .GT. NUM_HEADER_BLKS) THEN WRITE(OUTPUT,7150) ELSEIF (HBN .GT. 0 .AND. HBN .LE. NUM_HEADER_BLKS) THEN H$EXTNO = FILEID ITEMP = 0 DO 95 COUNTER = 1,HBN FILBLK = H$EXTNO + ISTART_BLOCK READ(LU_INDEX'FILBLK,ERR=800)HEADER 95 CONTINUE CALL DUMPIT(OUTPUT,HEADER) ELSE CLOSE (UNIT=1) GOTO 55 ENDIF GOTO 90 C********** I - Invert file header list ********** C C >Request user to verify this option is desired C >Request user to enter disk name, if none entered, use default. C >Open index file and read the home block. C >Extract starting point for the file headers from the home block. C >Outer Loop: C >Read the next file header, exit outer loop if no more. C >If the file header points to a deleted file, go to the next header C >Loop: C >For each map pointer, C >Determine format of map pointer. C >Extract logical block number and extent information. C >Store fileid in INVERTID array. C >Store logical block number and extent information in C INVERTPTR array. C >Increment pointers to next map pointer. C >If this is a multi-block header, read the next block and C goto start of loop. C >All file headers read, close the index file and return to the C main loop. C ELSEIF (RESP .EQ. 'I') THEN WRITE (OUTPUT,7600) READ (INPUT,7070,END=55) VERIF VERIF = CAPITALIZE(VERIF) IF (VERIF .NE. 'Y') GOTO 55 WRITE (OUTPUT,7300) DISK(1:DISKLEN) READ (INPUT,7070) TEMP_STRING IF (LENGTH(TEMP_STRING) .GT. 0) THEN DISK = TEMP_STRING DISKLEN = LENGTH(TEMP_STRING) ENDIF IF (INDEX(DISK(1:DISKLEN),':') .LE. 0) THEN DISK(DISKLEN+1:) = ':' DISKLEN = DISKLEN + 1 ENDIF WRITE (OUTPUT,7605) OPEN(UNIT=LU_INDEX 1 ,NAME=DISK(1:DISKLEN)//'[0,0]INDEXF.SYS' 2 ,ORGANIZATION='SEQUENTIAL',ACCESS='DIRECT' 3 ,READONLY,SHARED,TYPE='OLD',FORM='UNFORMATTED' 4 ,RECORDTYPE='FIXED',RECORDSIZE=128,ERR=810) READ (LU_INDEX'HOME_BLOCK_NO,ERR=2310) HOME_BLOCK ISTART_BLOCK = HB$SBCL*4 + HB$IBSZ MARKER = 1 DO 2300 FILEID = 1,25000 FILBLK = FILEID + ISTART_BLOCK READ(LU_INDEX'FILBLK,ERR=2310) HEADER IF (H$FNUM.EQ.0 .AND. H$FRVN.EQ.0) GOTO 2300 EXT_FLAG = .FALSE. IF (H$EXTNO .NE. 0) EXT_FLAG = .TRUE. 2000 MAPP = H$MAPPTR PTR = MAPP*2 NUM_MAPWORDS = 0 NUM_MAPWORDS = H$NO_MAPWORD * 2 TOT_MAPWORD = 0 2100 FORMAT_TYPE = HEADER_B(PTR+1) .AND. 'C0'X IF (FORMAT_TYPE .EQ. FORMAT0) THEN ICOUNT = 0 LBN = 0 INCPTR = 2 ELSEIF (FORMAT_TYPE .EQ. FORMAT1) THEN ICOUNT = 0 ICOUNT_B(1) = HEADER_B(PTR) LBN_B(4) = 0 LBN_B(3) = HEADER_B(PTR+1) .AND. '3F'X LBN_B(2) = HEADER_B(PTR+3) LBN_B(1) = HEADER_B(PTR+2) INCPTR = 4 ELSEIF (FORMAT_TYPE .EQ. FORMAT2) THEN ICOUNT = HEADER_W((PTR+1)/2) .AND. '3FFF'X LBN_W(1) = HEADER_W((PTR+1)/2 + 1) LBN_W(2) = HEADER_W((PTR+1)/2 + 2) INCPTR = 6 ELSEIF (FORMAT_TYPE .EQ. FORMAT3) THEN ICOUNT_W(2) = HEADER_W((PTR+1)/2) .AND. '3FFF'X ICOUNT_W(1) = HEADER_W((PTR+1)/2 + 1) LBN_W(1) = HEADER_W((PTR+1)/2 + 2) LBN_W(2) = HEADER_W((PTR+1)/2 + 3) INCPTR = 8 ENDIF IF (FORMAT_TYPE .EQ. FORMAT0) GOTO 2200 INVERTID(MARKER) = FILEID INVERTPTR(MARKER,1) = LBN INVERTPTR(MARKER,2) = ICOUNT MARKER = MARKER + 1 2200 PTR = PTR + INCPTR TOT_MAPWORD = TOT_MAPWORD + INCPTR IF (TOT_MAPWORD .LT. NUM_MAPWORDS .AND. 1 PTR .LT. 512) GOTO 2100 IF (EXT_FLAG) THEN FILBLK = H$EXTNO + ISTART_BLOCK READ(LU_INDEX'FILBLK,ERR=2310) HEADER IF (H$EXTNO .EQ. 0) EXT_FLAG = .FALSE. GOTO 2000 ENDIF 2300 CONTINUE 2310 INVERTEND = MARKER - 1 CLOSE (UNIT = LU_INDEX) GOTO 55 C*********** F - Find a LBN in the inverted pointer array ******** C C >Check that the inverted pointer array has been filled (I option), C if not, inform user of this and return to main loop. C >Prompt user to enter logical block number. C >If logical block number is 0 return to main loop. C >If logical block number is -1 user wishes to enter information C by cylinder, track, and sector numbers. C >Prompt and read cylinder number. C >Prompt and read track number. C >Prompt and read sector number. C >Compute and display logical block number from C,T,S information. C >If logical block number is -2 user wished to change S/T and T/C C information C >Prompt and read disk type C >Prompt and read sectors/track C >Prompt and read tracks/cylinder C >Ask for logical block number again C >Search the INVERTPTR array for a map pointer entry that contains the C requested logical block (i.e. start point <= LBN <= start point + C extent). C >If found, display the file header number, else say it is not contained C in a file. C ELSEIF (RESP .EQ. 'F') THEN IF (MARKER .EQ. 0) THEN WRITE (OUTPUT,7640) GOTO 55 ENDIF 2380 WRITE (OUTPUT,7610) READ (INPUT,7620,END=55,ERR=2380) INVERTLBN IF (INVERTLBN .EQ. 0) THEN GOTO 55 ELSE IF (INVERTLBN .EQ. -1) THEN 2382 WRITE (OUTPUT,7670) DISKTYPE READ (INPUT,7620,ERR=2382) CYL 2384 WRITE (OUTPUT,7680) DISKTYPE READ (INPUT,7620,ERR=2384) TRK 2386 WRITE (OUTPUT,7690) DISKTYPE READ (INPUT,7620,ERR=2386) SEC INVERTLBN = SECPERTRK * (CYL*TRKPERCYL + TRK) + SEC WRITE (OUTPUT,7700) INVERTLBN ELSE IF (INVERTLBN .EQ. -2) THEN 2387 WRITE (OUTPUT,7710) READ (INPUT,7740,ERR=2387) LDISKTYPE CALL STR$UPCASE (%DESCR(DISKTYPE),%DESCR(LDISKTYPE)) 2388 WRITE (OUTPUT,7720) READ (INPUT,7620,ERR=2388) SECPERTRK 2389 WRITE (OUTPUT,7730) READ (INPUT,7620,ERR=2389) TRKPERCYL GOTO 2380 ENDIF 2390 DO 2400 INVPT = 1,INVERTEND IF (INVERTPTR(INVPT,1) .LE. INVERTLBN .AND. 1 (INVERTPTR(INVPT,1)+INVERTPTR(INVPT,2)) .GE. INVERTLBN) 2 THEN WRITE (OUTPUT,7630) INVERTID(INVPT) GOTO 2380 ENDIF 2400 CONTINUE WRITE (OUTPUT,7650) GOTO 2380 C********** M - Display contents of mapwords ********** C C >Loop displaying mapword number, starting LBN, number of blocks ELSEIF (RESP .EQ. 'M') THEN DO 110 COUNTER = 1,INDEXX,16 IEND = COUNTER + 15 IF (IEND .GT. INDEXX) IEND = INDEXX WRITE (OUTPUT,7160) 1 (I,MAP(1,I),MAP(2,I),I=COUNTER,IEND) IF (IEND .LT. INDEXX) THEN WRITE (OUTPUT,7170) READ (INPUT,7070,END=55) RESP RESP = CAPITALIZE(RESP) IF (RESP .EQ. 'N') GOTO 55 ENDIF 110 CONTINUE GOTO 55 C********** C - Change EOF marker *********** C C >Display current value of allocated blocks. C >Display current value of Used blocks. C >Accept input for changing used blocks. C >Display current value of free byte. C >Accept input for changing first free byte. ELSEIF (RESP .EQ. 'C') THEN NEW_USED = R$EOF NEW_FREE = R$FREE WRITE(OUTPUT,7180)R$ALLOC 120 WRITE(OUTPUT,7190)R$EOF READ(INPUT,7070,END=55)LONGRESP IF(LENGTH(LONGRESP).GT. 0) 1 DECODE (LENGTH(LONGRESP),7090,LONGRESP,ERR=120)NEW_USED IF (NEW_USED .GT. R$ALLOC+1) THEN WRITE(OUTPUT,7210) NEW_USED = R$EOF ENDIF 130 WRITE(OUTPUT,7200)R$FREE READ(INPUT,7070,END=55)LONGRESP IF (LENGTH(LONGRESP) .GT. 0) 1 DECODE (LENGTH(LONGRESP),7090,LONGRESP,ERR=130)NEW_FREE IF (NEW_FREE .LT. 0 .OR. NEW_FREE .GT. 511) THEN WRITE(OUTPUT,7220) IF (NEW_FREE .GT. 511) WRITE(OUTPUT,7260)R$ALLOC+1 NEW_FREE = R$FREE ENDIF IF (NEW_USED .EQ. R$ALLOC+1 .AND. NEW_FREE .GT. 0) THEN WRITE(OUTPUT,7260)R$ALLOC+1 NEW_FREE = 0 ENDIF WRITE(OUTPUT,7180)R$ALLOC WRITE(OUTPUT,7190)NEW_USED,R$EOF WRITE(OUTPUT,7200)NEW_FREE,R$FREE R$EOF = NEW_USED R$FREE = NEW_FREE GOTO 55 C********** W - Write header ********** C C >Prompt user to find out if this was a valid request. C >If not, go back to loop. C >Build attribute list. C >Request output of file header. C >If fail, report error and stop. C >Go back for more. ELSEIF (RESP .EQ. 'W') THEN 140 WRITE(OUTPUT,7230) READ(INPUT,7070,END=55)RESP RESP = CAPITALIZE(RESP) IF (RESP .EQ. 'Y') THEN ATRIB_LIST_W(1) = ATR$S_RECATTR ATRIB_LIST_W(2) = ATR$C_RECATTR ATRIB_LIST(2) = %LOC(RECATTR) ATRIB_LIST(3) = 0 FIB$L_ACCTL = FIB$M_WRITE STATUS = SYS$QIOW(,%VAL(ICHAN) 1 ,IO$_DEACCESS,IOSB,,,FIB_DESCR,, 2 NAMELEN,NAMEBUF,ATRIB_LIST,) IF (STATUS .NE. %LOC(SS$_NORMAL) 1 .OR. IOSB_W(1) .NE. %LOC(SS$_NORMAL))THEN CALL FIX_REPORT 1 ('Error during file header update ''' 2 //NCODE(IOSB)//'''X') GOTO 1000 ELSE WRITE(OUTPUT,7310) ENDIF GOTO 10 ENDIF GOTO 55 C********** N - New file ********** C C >Branch to cleanup and then start over. ELSEIF (RESP .EQ. 'N') THEN GOTO 1000 C********** E - Exit ********** C C >Branch to cleanup and exit. ELSEIF (RESP .EQ. 'E') THEN GOTO 1000 C********** H (or any invalid code) - HELP ********** C C >Display list of valid codes. C >Branch to main loop. ELSE WRITE(OUTPUT,7500) GOTO 55 ENDIF C********** Error handler ********** C 800 CALL FIX_REPORT('Error reading index file.') GOTO 1000 810 CALL FIX_REPORT('Error opening index file.') GOTO 1000 C********** Exit routine ********** C 1000 STATUS = SYS$QIOW(,%VAL(ICHAN),IO$_DEACCESS,IOSB,,,FIB_DESCR 1 ,NAMELEN,NAMEBUF,,) 1005 CALL SYS$DASSGN(ICHAN) IF (RESP .EQ. 'N') THEN GOTO 10 ELSE IF (RESP .NE. 'E') GOTO 55 ENDIF 1010 WRITE(OUTPUT,7250) STOP ' ' 7000 FORMAT(/' ********** FIX FILE HEADER PROGRAM **********'/) 7010 FORMAT(/' Enter file name or "ID=" (or ^Z to exit) : '$) 7020 FORMAT($Q,A) 7030 FORMAT(O) 7040 FORMAT(' File id is not block one of the file header ') 7050 FORMAT(/ ' File name stored in header : ',4X,A 1 /' Full path name is : ',/13X,A,A 2 /' File id :' 3 ,<15-LENGTH(FILEID_STRING)>X,A 4 /' Used/Allocated blocks : ' 5 ,<14-LENGTH(BLOCK_STRING)>X,A 6 /' First free byte : ',9X,I5 7 /' File owner : ',5X,A 8 /' Number of file headers : ',9X,I5 9 /' Number of map pointers : ',9X,I5 1 /) 7051 FORMAT(/ ' File name stored in header : ',4X,A 1 /' Full path name is : ',/13X,A,A 2 /' File id :' 3 ,<15-LENGTH(FILEID_STRING)>X,A 4 /' Used/Allocated blocks : ' 5 ,<14-LENGTH(BLOCK_STRING)>X,A 6 /' First free byte : ',11X,'eof' 7 /' File owner : ',5X,A 8 /' Number of file headers : ',9X,I5 9 /' Number of map pointers : ',9X,I5 1 /) 7060 FORMAT(/' Enter Program Option : '$) 7070 FORMAT($A) 7080 FORMAT(/' Enter Virtual Block number : '$) 7090 FORMAT(I) 7100 FORMAT(/' -- Virtual block number exceeds allocated blocks -- '/) 7110 FORMAT(/' -- Error from QIO : you need LOG_IO privilege to use' 1 ,' this command --') 7120 FORMAT(/' Enter Logical Block number : '$) 7130 FORMAT(/' -- Logical block number does not exist in the map --'/) 7140 FORMAT(/' Enter Header Block number : '$) 7150 FORMAT(/' -- Header block number exceeds total ' 1 ,'number of header blocks --'/) 7160 FORMAT(/' PTR # # of blocks LBN ' 1 //(1X,I4,'.',9X,I6,4X,I10)) 7170 FORMAT(50X,'***More ? '$) 7180 FORMAT(/' Allocated blocks : ',i6) 7190 FORMAT(' Used blocks : ',i6,' : '$:' (',i6,').') 7200 FORMAT(' First free byte : ',i6,' : '$:' (',i6,').') 7210 FORMAT(/' -- Used blocks exceeds number of allocated blocks --'/) 7220 FORMAT(/' -- First free byte must be between 0 and 511 --'/) 7230 FORMAT(/' Rewrite of file header' 1 ,' Do you wish to update the disk? '$) 7250 FORMAT(/' ********** End of Fixheader program **********') 7260 FORMAT( /' If you want to place EOF at physical end of file ' 1 ,'specify: used -',i5,', free - 0.') 7270 FORMAT('(',O5,',',O4,',',O2,')') 7280 FORMAT(I5,'./',I5,'.') 7290 FORMAT('(',O3,',',O3,')') 7300 FORMAT(' Enter disk name <',A,'> : '$) 7310 FORMAT(' Update of header complete.') 7320 FORMAT(/' -- Invalid file specification --'/) 7330 FORMAT(/' -- Privilege violation - you do not have read/write' 1 ,' access to this file. --'/) 7500 FORMAT( /' Request codes include : ' 1 /' ? - Display this message.' 2 /' G - Display general information. ' 3 /' M - Display map pointers.' 4 /' V - Display data by virtual block.' 5 /' L - Display data by logical block.' 6 /' H - Display header block.' 7 /' I - Invert file extent pointers.' 8 /' F - Find file id by LBN.' 9 /' C - Change end of file marker.' 1 /' W - Update changes on disk.' 2 /' N - New file.' 3 /' E - Exit.' 4 /) 7600 FORMAT (/' This takes a long time, are you sure? : '$) 7601 FORMAT (/' Enter disk name : '$) 7605 FORMAT (/' OK, excuse me while I hack this disk...') 7610 FORMAT (/' Enter logical block number (decimal)',/, 1 ' or -1 to use C/T/S format',/, 2 ' or -2 to change S/T and T/C information : '$) 7620 FORMAT (I6) 7630 FORMAT (/' This LBN is contained in file header number ',O5, 1 ' (octal)') 7640 FORMAT (/' This operation must be preceded by I(nvert)') 7650 FORMAT (/' This LBN is not contained in any file') 7660 FORMAT (A) 7670 FORMAT (/' Enter cylinder number (decimal) (',A4,' disk) : '$) 7680 FORMAT (' Enter track number (decimal) (',A4,' disk) : '$) 7690 FORMAT (' Enter sector number (decimal) (',A4,' disk) : '$) 7700 FORMAT (' This C,T,S is for LBN number ',I6,' (decimal)') 7710 FORMAT (/' Enter disk type (e.g. RM05) : '$) 7720 FORMAT (' Enter sectors/track : '$) 7730 FORMAT (' Enter tracks/cylinder : '$) 7740 FORMAT (A4) END C********** DUMPIT - formatted dump of a blocks ********** C C DUMPIT is called to display a block of information. C The left half of the display contains the hex dump. C The right half contains the ASCII for any character that C can be translated. SUBROUTINE DUMPIT(OUTPUT,BLOCK) BYTE BLOCK(0:511) INTEGER*2 BLK INTEGER*2 OUTPUT CHARACTER*1 RESP CHARACTER*46 OUTREC BYTE ASCOUT(16) C********** Explanation of locals and parameters ********** C C BLOCK = (parameter)byte array to be displayed C OUTPUT = (parameter)logical unit number to write to. C RESP = character variable used for user response. C OUTREC = character variable used for formatting hex data. C ASCOUT = array used for outputting ascii data. DO 200 M = 1,2 DO 100 I = (M-1)*256,(M*256)-1,16 ENCODE(46,7000,OUTREC,ERR=100) 1 I,(BLOCK(J+I),J=0,15) DO 15 N = 1,46 IF (OUTREC(N:N) .EQ. ' ' .AND. MOD(N-1,5) .NE. 0) 1 OUTREC(N:N) = '0' 15 CONTINUE DO 20 N = I,I+15 NN = N - I + 1 BLK = BLOCK(N) IF (BLOCK(N) .GE. 32 .AND. BLOCK(N) .LE. 126) 1 THEN ASCOUT(NN) = BLOCK(N) ELSE ASCOUT(NN) = 32 ENDIF 20 CONTINUE WRITE(OUTPUT,7010)OUTREC,ASCOUT 7010 FORMAT(5X,A46,4X,'<',16A,'>') 7000 FORMAT(Z4,':',8(1X,2Z2)) 100 CONTINUE IF ( M.EQ. 1) 1 THEN CALL LIB$GET_INPUT(RESP,' '// 1 '*** More ? ') IF (RESP .NE. 'Y' .AND. RESP .NE. 'y') RETURN ENDIF 200 CONTINUE RETURN END C********** LENGTH - returns length of string ********** C C LENGTH returns actual length of string - that is LEN C excluding any trailing blanks and/or nulls. INTEGER*4 FUNCTION LENGTH(STR) CHARACTER*(*) STR CHARACTER*1 NULL BYTE NULL_B(1) EQUIVALENCE (NULL,NULL_B(1)) DATA NULL_B /0/ DO 10 I = LEN(STR),1,-1 LENGTH = I IF(STR(I:I) .NE. ' ' .AND. STR(I:I) .NE. NULL) GO TO 20 10 CONTINUE LENGTH = 0 20 RETURN END C********** STRIP_BLANKS - strips all blanks from input string ********** C C STRIP_BLANKS strips all blanks from input argument and returns C the result in STRIP_BLANKS FUNCTION STRIP_BLANKS(STRING) CHARACTER*(*) STRIP_BLANKS,STRING INTEGER*4 LENT,I,J LENT = LEN(STRIP_BLANKS) STRIP_BLANKS=' ' I = 1 DO 10 J = 1, LEN(STRING) IF (STRING(J:J) .NE. ' ') THEN STRIP_BLANKS(I:I) = STRING(J:J) I = I + 1 IF ( I .GT. LENT ) RETURN ENDIF 10 CONTINUE RETURN END C********** CAPITALIZE - convert string to upper case ********** C CHARACTER*(*) FUNCTION CAPITALIZE(STRING) CHARACTER*(*) STRING INTEGER*4 NOSMALL CHARACTER*1 SMALLA,SMALLZ DATA SMALLA,SMALLZ,NOSMALL /'61'X,'7A'X,'DF'X/ C************ Explanations of locals and parameters ********* C C STRING = (parameter) string to convert. C SMALLA,SMALLZ= ASCII for 'a','z' C NOSMALL = mask to convert to upper case. C CAPITALIZE = ' ' DO 10 I = 1,LENGTH(STRING) IF (STRING(I:I) .GE. SMALLA .AND. STRING(I:I) .LE. SMALLZ) 1 THEN CAPITALIZE(I:I) = CHAR(ICHAR(STRING(I:I)) .AND. NOSMALL) ELSE CAPITALIZE(I:I) = STRING(I:I) ENDIF 10 CONTINUE RETURN END C********** ZERO_FILL - replaces all blanks with zeros ********** C C ZERO_FILL replaces all blanks in input argument STRING with zeros C and returns result in ZERO_FILL FUNCTION ZERO_FILL(STRING) CHARACTER*(*) ZERO_FILL,STRING INTEGER*4 LENT,I,J ZERO_FILL=STRING DO 10 J = 1, LEN(STRING) IF (STRING(J:J) .EQ. ' ') ZERO_FILL(J:J) = '0' 10 CONTINUE RETURN END C********** REPORT - Report severe error ********** SUBROUTINE FIX_REPORT(MESSAGE) CHARACTER*(*) MESSAGE ! Parameter CHARACTER*4 MESS_CODE CHARACTER*1 BELL INTEGER*2 MKR,MKR2 DATA BELL/7/ C********** Explanation of parameters and locals ********** C C MESSAGE = (*)-character message describing error. C BELL = character contains ascii code for the bell. C********** Reporting of severe error ********** C C >Type severe error report on terminal: C >Ring bell. C >Type heading. C >Type message describing error. C >Search the library definition file for the text of the error code. C Some messages may contain two error codes. CALL LIB$PUT_OUTPUT(BELL) CALL LIB$PUT_OUTPUT(' --- FIXHEADER program severe error ---') CALL LIB$PUT_OUTPUT(' Message: '//MESSAGE) CALL LIB$PUT_OUTPUT(' (note: err codes are for system services)') MKR=INDEX(MESSAGE,'''X') MESS_CODE=MESSAGE(MKR-4:MKR-1) CALL LIB$SPAWN ('$SEARCH SYS$LIBRARY:SSDEF.FOR '//MESS_CODE,,,6) MKR=MKR+1 MKR2=INDEX(MESSAGE(MKR:),'''X') IF (MKR2.NE.0) THEN MESS_CODE=MESSAGE(MKR+MKR2-5:MKR+MKR2-2) CALL LIB$SPAWN ('$SEARCH SYS$LIBRARY:SSDEF.FOR '//MESS_CODE,,,6) ENDIF RETURN END C********** NCODE - Code error status into external format ********** CHARACTER*(*) FUNCTION NCODE(ERROR_NUMBER) INTEGER*4 ERROR_NUMBER ! Parameter C********** Explanation of parameters ********** C C ERROR_NUMBER = integer*4 number containing error code C ENCODE(8,10,NCODE)ERROR_NUMBER 10 FORMAT(Z8) DO 20 I = 1,8 IF (NCODE(I:I) .EQ. ' ') NCODE(I:I) = '0' 20 CONTINUE RETURN END