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 DCOLAT C C Program to read an input file and create one or more output files from it C LOGICAL*1 OPEN1,OPEN2 C BYTE FILNAM(16) C INTEGER*2 IQ,FILSIZ,ISIZE,BUFFER(256) C REAL*8 PROMPT C 1 CONTINUE TYPE 2 2 FORMAT (////'1DECOLLATE FILES'/'0This program will read the & file you specify and split it into smaller'/' files on the & device(s) you name.'//' The decollation is block by block: & use COLLATE to combine the files again.'/) 10 CONTINUE C C get the input file name C OPEN1 = .FALSE. PROMPT = ' input ' CALL GETNAM (FILNAM,PROMPT,IQ) C C If no entry - program done C IF (IQ .LT. 1) GO TO 900 C C See if the file exists?? C PAUSE 'Press when the input device is ready' C OPEN (UNIT=1,NAME=FILNAM,TYPE='OLD',ERR=800,READONLY, &RECORDSIZE=128,CARRIAGECONTROL='NONE',FORM='UNFORMATTED', &ACCESS='DIRECT',ASSOCIATEVARIABLE=IBLK1,DISP='KEEP') OPEN1 = .TRUE. IBLK1 = 1 ! Starting read block OPEN2 = .FALSE. FILSIZ = 0 ! Output space available ISIZE = 950 ! Default file size 30 CONTINUE C C Read a block and transfer it to the output, if there's room C READ (1'IBLK1,ERR=850) (BUFFER(I),I=1,256) IF (FILSIZ .GT. 0) GO TO 50 ! Write next block 31 CONTINUE C C First time or ran out of space - get next output file C IF (OPEN2) CLOSE (UNIT=2,DISP='KEEP') OPEN2 = .FALSE. 32 CONTINUE C C Get the number of free blocks C TYPE 33,ISIZE 33 FORMAT (/' Enter the number of free blocks on the output & device. Default: ',I4/' * ',$) READ (5,34,ERR=37) IQ,I 34 FORMAT (Q,I4) IF (IQ .LT. 1) GO TO 40 IF (I .GT. 1) GO TO 39 TYPE 36 36 FORMAT (/' The block length must be > 1') 37 CONTINUE CALL TTERR GO TO 32 39 CONTINUE ISIZE = I ! New output size 40 CONTINUE FILSIZ = ISIZE ! Available blocks PROMPT = ' output ' CALL GETNAM (FILNAM,PROMPT,IQ) C C If no entry - program done C IF (IQ .LT. 1) GO TO 900 C C See if there is enough space C PAUSE 'Press when the output device is ready' C OPEN (UNIT=2,NAME=FILNAM,TYPE='NEW',ERR=700, &RECORDSIZE=128,CARRIAGECONTROL='NONE',FORM='UNFORMATTED', &ACCESS='DIRECT',ASSOCIATEVARIABLE=IBLK2,INITIALSIZE=FILSIZ) OPEN2 = .TRUE. IBLK2 = 1 50 CONTINUE C C Write next block and reduce availability C WRITE (2'IBLK2,ERR=840) (BUFFER(I),I=1,256) FILSIZ = FILSIZ - 1 GO TO 30 C C File errors C 700 CONTINUE TYPE 701 701 FORMAT (/' ? Unable to start new output file. Try another.') GO TO 31 800 CONTINUE TYPE 801 801 FORMAT (/' ? Unable to locate input file. Try another.') GO TO 10 840 CONTINUE TYPE 841 841 FORMAT (/' Error writing output file - deleted.'/) CLOSE (UNIT=2,DISP='DELETE') GO TO 960 850 CONTINUE TYPE 851 851 FORMAT (/' Reached end of input file.'/) GO TO 950 900 CONTINUE TYPE 901 901 FORMAT (/' Program ends at your request.'/) 950 CONTINUE IF (OPEN2) CLOSE (UNIT=2) 960 CONTINUE IF (OPEN1) CLOSE (UNIT=1) PAUSE 'Press to continue ...' CALL EXIT END SUBROUTINE GETNAM (FILNAM,LINE,IQ) C C Subroutine to read terminal and get next file name C BYTE FILNAM(16),LINE(8) C INTEGER*2 IQ C 1 CONTINUE TYPE 2,(LINE(I),I=1,8) 2 FORMAT (/' Enter the device and file name of an ',8A1, &' file. Default: none'/' * ',$) READ (5,3,ERR=10) IQ,(FILNAM(I),I=1,14) 3 FORMAT (Q,16A1) IF (IQ .LT. 1) RETURN ! No file IF (IQ .LT. 3) GO TO 5 ! Name too short IF (IQ .GT. 14) GO TO 5 ! Name too long FILNAM (IQ+1) = "0 RETURN 5 CONTINUE TYPE 6 6 FORMAT (/' ? File name error. Too long or short.') 10 CONTINUE CALL TTERR GO TO 1 END SUBROUTINE TTERR C C Sends error message to terminal C TYPE 2 2 FORMAT (/' Terminal or entry error - re-specify.') RETURN END