C............................................................................. C C Walter L. Battaglia C YOLO EXPERT SOFTWARE C 1111 Kennedy Place, Suite 4 C Davis, CA 95616 C C (916) 758-8940 C C............................................................................. C C LICENSE & DISCLAIMER C C The programs and procedures described herein were designed and written by C Walter L. Battaglia (hereafter, the writer). The writer reserves the right C to make use of this material in other applications, and all rights of sale C and distribution. C C The writer herewith grants the right to use this program to the Digital C Equipment Computer User's Society (DECUS), its affiliates, and members. C C These programs and materials are distributed without warranty. The writer C assumes no liability whatever for their use in any application. C C............................................................................. C C ACKNOWLEDGEMENTS C C "DEC", "RT-11", "RSX-11/M", "VAX", "VMS", "VT52", "VT100", "VT220", "LA100", C "LA120", "PDP-11", and "LSI-11/23" are trademarks and/or products of the C DIGITAL EQUIPMENT CORP., MAYNARD, MASS. C C "TSX-PLUS" and "COBOL-PLUS" are trademarks and/or products of S&H COMPUTERS, C NASHVILLE, TENN. C C............................................................................. PROGRAM ASIS ! ASsign ISam C C Program to read the home block of an S&H Computers' COBOL-PLUS ISAM index C file to determine and/or change the location the device assigments. C LOGICAL*1 FNAME,FNAME1,DNAME,OPENED,NULL,FIRST,DATAF C INTEGER*2 IBUFF,IBLOCK,IRDQ,IOERRS,TTERRS,I,J,K,WORD0,WORD1 C REAL*4 REAL1 REAL*8 REAL2 C DIMENSION IBUFF(256),FNAME(16),FNAME1(16),DNAME(8) C EQUIVALENCE (FNAME1(1),REAL1),(REAL2,DNAME(1)) C 001 CONTINUE NULL = "0 IOERRS = 0 C 1000 CONTINUE ! Get file definition from user OPENED = .FALSE. TTERRS = 0 1005 CONTINUE TYPE 1007 1007 FORMAT (' Enter ISAM device & file name: ',$) 1010 CONTINUE READ (5,1011,ERR=1900) IRDQ,(FNAME(I),I=1,IRDQ) 1011 FORMAT (Q,16A1) C C Check the dev and filespec parameters C IF ((IRDQ .LT. 3) .OR. (IRDQ .GT. 10)) GO TO 1900 DO 1015 I=(IRDQ+1),16 FNAME (I) = ' ' 1015 CONTINUE I = 1 J = 1 1020 CONTINUE IF (FNAME (I) .EQ. ':') GO TO 1030 IF (FNAME (I) .EQ. ' ') GO TO 1900 ! No imbedded blanks FNAME1 (J) = FNAME (I) I = I + 1 J = J + 1 IF (I .LE. 4) GO TO 1020 GO TO 1900 ! Bad device spec 1030 CONTINUE I = I + 1 IF (FNAME (I) .EQ. ':') GO TO 1900 ! Avoid RT-11 file spec bug IF (FNAME (I) .EQ. '.') GO TO 1040 ! End of name IF (FNAME (I) .NE. ' ') GO TO 1035 ! End of name? IF (FNAME (I+1) .EQ. ' ') GO TO 1040 ! Yes GO TO 1900 ! Else error 1035 CONTINUE FNAME1 (J) = FNAME (I) J = J + 1 IF (I .LT. IRDQ) GO TO 1030 I = IRDQ + 1 1040 CONTINUE C J is the PTR to NEXT byte in FNAME1; adjust to actual length J = J - 1 C Check for RAD50, if OK go open the file K = IRAD50 (J,FNAME1(1),REAL2) IF (K .EQ. J) GO TO 2000 ! RAD50 file name OK C 1900 CONTINUE ! Terminal or file spec error TTERRS = TTERRS + 1 IF (TTERRS .GT. 4) GO TO 9300 TYPE 1901 1901 FORMAT (' ? File name error: Respecify.') GO TO 1005 C 2000 CONTINUE ! Open Index file .CI0 C C Complete the file name: dev:filnam entered; add ".CI0"; ASCIZ format C I points to NEXT byte in FNAME C FNAME (I) = '.' FNAME (I+1) = 'C' FNAME (I+2) = 'I' FNAME (I+3) = '0' FNAME (I+4) = NULL C OPEN (UNIT=2,NAME=FNAME(1),TYPE='OLD',DISP='SAVE', &ACCESS='DIRECT',ASSOCIATEVARIABLE=IBLOCK,RECORDSIZE=128, &CARRIAGECONTROL='NONE',FORM='UNFORMATTED',ERR=2900) OPENED = .TRUE. C 2100 CONTINUE ! read the home block READ (2'1,ERR=2950) (IBUFF(I),I=1,256) 2150 CONTINUE C C Set first time switch, do over return C FIRST = .TRUE. 2200 CONTINUE ! data to user WORD0 = IBUFF (1) ! Number of keys WORD0 = WORD0 .AND. "377 ! Clear high byte INDEXF = WORD0 ! Save the # INDEXS = WORD0 ! Save again WORD1 = IBUFF(1) / 256 ! Number non-unique keys WORD1 = WORD1 .AND. "377 ! Clear high byte TYPE 2203,WORD0 2203 FORMAT (/' Number of Index Files: ',I2) TYPE 2204,WORD1 2204 FORMAT (' Number of non-unique keys: ',I2/' ') C I = 1 ! Current Index file # K = 48 ! PTR device name C 2210 CONTINUE ! Show the index devices WORD1 = IBUFF (K) ! Device name C Type the next index name on the screen CALL R50ASC (3,WORD1,FNAME1(1)) TYPE 2211,I,(FNAME1(J),J=1,3) 2211 FORMAT (' Index file for key ',I2,' resides on ',3A1,':') I = I + 1 K = K + 8 ! skip 7 words IF (I .LE. WORD0) GO TO 2210 C C Get the data file count, and type totals line C WORD0 = IBUFF (2) TYPE 2213,WORD0 2213 FORMAT (' Number of Data Files: ',I1/' ') I = 1 ! Reset I 2220 CONTINUE ! Show the data file devices WORD1 = IBUFF (K) ! data file name C Type the next data file name on the screen CALL R50ASC (3,WORD1,FNAME1(1)) TYPE 2221,I,(FNAME1(J),J=1,3) 2221 FORMAT (' Data file segment ',I1,' resides on ',3A1,':') I = I + 1 C Error: Data file name is word followed by data file size word; skip 1 word K = K + 2 IF (I .LE. WORD0) GO TO 2220 C Check first time IF (.NOT. FIRST) GO TO 8100 ! Second Pass (after changes) DATAF = .FALSE. REAL2 = 'Index ' 2295 CONTINUE ! Entry point for device query TTERRS = 0 ! Init error count C 2300 CONTINUE ! Get the requested changes TYPE 2301,(DNAME(J),J=1,5) 2301 FORMAT ('Enter the ',5A1,' File # to be changed; & Press RETURN to change none: ',$) K = 0 READ (5,2303,ERR=2800) IRDQ,K 2303 FORMAT (Q,I2) IF (IRDQ .LT. 1) GO TO 2400 ! End of Index changes IF ((K .LT. 1) .OR. (K .GT. INDEXF)) GO TO 2800 ! Error C K has the index file number to be changed TTERRS = 0 2350 CONTINUE TYPE 2305,(DNAME(J),J=1,5),K 2305 FORMAT (' Enter the new Device for ',5A1,' File ',I2,': ',$) READ (5,2307,ERR=2850) IRDQ,(FNAME1(J),J=1,IRDQ) 2307 FORMAT (Q,16A1) IF (IRDQ .LT. 1) GO TO 2295 ! No change - start over IF (IRDQ .GT. 3) GO TO 2850 DO 2310 J=IRDQ+1,3 FNAME1 (J) = ' ' 2310 CONTINUE I = IRAD50 (3,FNAME1(1),WORD1) IF (I .NE. 3) GO TO 2850 IF (DATAF) GO TO 2320 C C Calculate place to put next device name for indices C - skipping 8 words after each name C J = 48 I = J + (8*(K-1)) GO TO 2395 2320 CONTINUE C Data segment names start after index names J = 48 + INDEXS * 8 C Calculate place to put next data segment device name = last word + 2 I = J + (2*(K-1)) 2395 CONTINUE C Store the RAD50 device name IBUFF (I) = WORD1 GO TO 2295 ! Next change C 2400 CONTINUE ! Change data file devices C C Loop through, doing the data files; reset INDEXF C IF (DATAF) GO TO 8000 !Data query done INDEXF = IBUFF (2) !Total data files DATAF = .TRUE. REAL2 = 'Data ' GO TO 2295 !Restart loop C 2800 CONTINUE TTERRS = TTERRS + 1 IF (TTERRS .GT. 4) GO TO 9300 !Too many errors TYPE 2801,INDEXF 2801 FORMAT (' ? Index File must be a NUMBER from 1 to ',I2) GO TO 2300 C 2850 CONTINUE TTERRS = TTERRS + 1 IF (TTERRS .GT. 4) GO TO 9300 !Too many errors TYPE 2851 2851 FORMAT (' ? Illegal device name. Respecify.') GO TO 2350 C 2900 CONTINUE ! OPEN ERROR - Bad file? IOERRS = IOERRS + 1 IF (IOERRS .GT. 3) GO TO 9300 ! Too many errors TYPE 2901 2901 FORMAT (' ? Unable to Locate file: Start over.') GO TO 1000 C 2950 CONTINUE TYPE 2951 2951 FORMAT (/' ? Read error on file ... ',$) GO TO 9100 C 8000 CONTINUE ! Rewrite the home block FIRST = .FALSE. GO TO 2200 ! Show the list of devices 8100 CONTINUE TYPE 8001 8001 FORMAT (' CHANGE HOME BLOCK: Enter Y to change, & N to do over. Press RETURN to quit: ',$) READ (5,1011,ERR=9000) IRDQ,(FNAME1(I),I=1,IRDQ) IF (IRDQ .LT. 1) GO TO 9000 IF (IRDQ .GT. 3) GO TO 9000 IF (FNAME1 (1) .EQ. 'N') GO TO 2150 IF (FNAME1 (1) .NE. 'Y') GO TO 9000 WRITE (2'1,ERR=8900) (IBUFF(I),I=1,256) C TYPE 8007 8007 FORMAT (' ISAM Devices changed: ',$) GO TO 9100 C 8900 CONTINUE TYPE 8901 8901 FORMAT (' ? Error writing home block: ',$) GO TO 9100 C 9000 CONTINUE TYPE 9001 9001 FORMAT (' No changes were made.',$) C 9100 CONTINUE TYPE 9101 9101 FORMAT ('+',' Verify file status with the ISAM utility.') GO TO 9900 C 9300 CONTINUE TYPE 9301 9301 FORMAT (/' ? Too many errors: Program halt.') C 9900 CONTINUE IF (OPENED) CLOSE (UNIT=2) CALL EXIT END