C************************************************ C* * C* CPMDEC--CP/M TO DEC DISK TRANSLATER * C* * C* NOTE: MUST BE COMPILED '/NOSWAP' * C* * C* PROCESSING SCHEME: * C* THE (SINGLE DENSITY) CP/M DISK IS PHYS- * C* ICALLY THE SAME AS AN RX-01 DISK. * C* THUS WE OPEN DY1: AS A NON-FILE STRUC- * C* TURED DEVICE AND READ IT WITH THE SYSTEM * C* CALL ISPFNW, DOING OUR OWN INTERLEAVING. * C* * C* RX-01 READS 64 WORD SECTORS (128 BYTES, * C* SAME AS IBM AND CP/M). THE ISPFNW CALL * C* ALLOWS READING AND WRITING ABSOLUTE * C* PHYSICAL SECTORS. * C* * C* MORE INFORMATION ON RX-01 FORMAT DISKS IS * C* IN THE DEC PERIPHERALS HANDBOOK. * C* * C* EACH DISK CONTAINS 77 TRACKS (0..76), OF * C* 26 SECTORS EACH. CP/M INTERLEAVES THE * C* SECTORS; THIS IS TAKEN CARE OF IN SUB * C* DOSEC. RX-01 USES A DIFFERENT INTERLEAVE * C* SCHEME; BUT THIS IS OF NO CONCERN TO US * C* BECAUSE ISPFNW READS ABSOLUTE PHYSICAL * C* SECTORS. * C* * C* CP/M GROUPS 8 LOGICAL SECTORS INTO A * C* CLUSTER (1K) NUMBERED 0..240. CLUSTERS * C* ARE NUMBERED SEQUENTIALLY STARTING ON * C* TRACK 2; THE DIRECTORY (2K) IS CLUSTERS * C* 0 AND 1. TRACKS 0 AND 1 ARE SYSTEM * C* TRACKS. * C* * C* EACH DIRECTORY ENTRY IS 32 BYTES: * C* 1: 0 IF ACTIVE, 0E5H ("345) INACTIVE * C* 2-9: FILE NAME * C* 10-12: FILE TYPE * C* 13: EXTENT # [0...] * C* 14-15: OF NO CONCERN TO US * C* 16: # OF SECTORS IN THIS EXTENT * C* (0..128) * C* 17-32: NUMBERS, IN ORDER USED, OF UP * C* TO 16 CLUSTERS. (IF FILE IS OVER 16K, * C* ANOTHER DIRECTORY ENTRY IS CREATED * C* WITH THE EXTENT # INCREMENTED; AND UP * C* TO 16 MORE CLUSTERS ASSIGNED). UNUSED * C* CLUSTER ENTRIES ARE 0. * C* * C* RUSS BAKKE 02-17-83 * C* * C************************************************ C * C CHANGED FOR USE IN R S X - SYSTEMS * C 12.10.84 BY: H.K. * C * C************************************************ C PROGRAM CPMDEC C INTEGER DY,DK,PR C DIMENSION IS(2), LS(2), IP(6), LP(6) C BYTE DIR(32,64),CNAME(12),DNAME(30),LBUFF(80) BYTE BITMAP(256),DBUFF(1024),MODE(6) BYTE BE,EMPT COMMON DIR COMMON /IOBL/IS,IP,LS,LP C DATA DY/1/ DATA DK/2/ DATA PR/3/ DATA IP/0,128,0,0,0,0/ DATA LP/0,1024,0,0,0,0/ DATA BE/7/ DATA EMPT/"345/ C DATA DNAME/ 'D','Y','0',':',26*0/ DATA BITMAP/ 2*1,254*0/, MODE /'A','S','C','I','I',' '/ C EQUIVALENCE (ICHAN,DY) EQUIVALENCE (IDCHAN,DK) C TYPE 100,BE 100 FORMAT (1X,A1,'CP/M DISK READER, V2.1 (RSX)'// + 1X,'INSERT CP/M DISK IN DY: AND PRESS RETURN'/) ACCEPT 104,IWANT C C attach floppy and test for density C CALL WTQIO("1400,DY,DY,,IS,,ID) ! ATTATCH I = ISTAT(IS,ID,-1) CALL WTQIO("2520,DY,DY,,IS,,ID) ! SENSE CHARACTERISTICS OF FLOPPY I = ISTAT(IS,ID,-2) C C S: 1 1000 - SINGLE DENSITY C S: 1 5000 - DOUBLE DENSITY C DENS = IAND(IS(2),"4000) IF (DENS.NE.0) STOP 'density error on Floppy' C C 10 IPRINT=0 ICPL = 2 ICPH = 12 TYPE 102,MODE 102 FORMAT (/,1X,'COPY MODE IS ',6A1,/, + 1X,'ENTER NUMBER OF OPTION DESIRED:',/, + 1X,'1 - DISPLAY CP/M DIRECTORY',/, + 1X,'2 - PRINT CP/M DIRECTORY',/, + 1X,'3 - COPY A FILE FROM CP/M DISK',/, + 1X,' WILDCARDS ALLOWED: * ',/, + 1X,'4 - COPY ALL FILES FROM CP/M DISK ',/, + 1X,'5 - INITIALIZE A CP/M DISK',/, + 1X,'6 - DELETE A FILE FROM CP/M DISK',/, + 1X,'7 - COPY FILE TO CP/M DISK',/, + 1X,'8 - CHANGE COPY MODE',/, + 1X,'9 - QUIT') TYPE 103,BE 103 FORMAT ( 1X, 'CPM>' 1A1 $ ) READ (5,104,END=99,ERR=10) IWANT 104 FORMAT (I2) IF (IWANT .LT. 1 .OR. IWANT .GT. 9) GOTO 10 IF (IWANT .EQ. 1) GOTO 11 IF (IWANT .EQ. 3) GOTO 30 IF (IWANT .EQ. 4) GOTO 40 IF (IWANT .EQ. 5) GOTO 50 IF (IWANT .EQ. 6) GOTO 60 IF (IWANT .EQ. 7) GOTO 70 IF (IWANT .EQ. 8) GOTO 62 IF (IWANT .EQ. 9) GOTO 99 C C FALL THROUGH IS 2 (PRINT DIRECTORY OF CP/M DISK) IPRINT=1 OPEN (UNIT=PR,NAME='CPMTRA.LST',TYPE='NEW',ERR=26) C C DISPLAY DIRECTORY 11 CALL GETDIR(ICHAN) !READ DIRECTORY ITOTAL=0 C C DISPLAY DIRECTORY DO 12 I=1,80 !CLEAR LBUFF LBUFF(I) = ' ' 12 C O N T I N U E IBFPTR = 0 C DO 24 INDEX=1,64 IF (DIR(1,INDEX) .EQ. EMPT) GOTO 24 !EMPTY ENTRY IF (DIR(13,INDEX) .NE. 0) GOTO 24 !LATER EXTENT ISIZE = DIR(16,INDEX) IF (ISIZE .LT. 0) ISIZE=ISIZE+256 IF (ISIZE .EQ. 128) GOTO 14 !MULTIPLE EXTENTS ISIZE = (ISIZE+7)/8 GOTO 22 C C MULTIPLE EXTENT FILE; MUST GET SIZE FROM LATER EXTENTS 14 DO 16 IPTR=2,12 CNAME(IPTR-1)=DIR(IPTR,INDEX) 16 C O N T I N U E IEXT=1 18 ISIZE=0 CALL FIND (CNAME,IEXT,IENTRY,-2,12) IF (IENTRY .EQ. -1) GOTO 20 !NO MORE EXTENTS ISIZE=DIR(16,IENTRY) IF (ISIZE .LT. 0) ISIZE=ISIZE+256 IF (ISIZE .NE. 128) GOTO 20 !NO MORE EXTENTS IEXT=IEXT+1 GOTO 18 C 20 ISIZE=(ISIZE+7)/8 + 16*IEXT C 22 ENCODE(16,120,LBUFF(18*IBFPTR+2)) + (DIR(J,INDEX),J=2,12),ISIZE 120 FORMAT (8A,'.',3A,I3,'K') ITOTAL=ITOTAL+ISIZE IBFPTR = IBFPTR+1 IF (IBFPTR .LE. 3) GOTO 24 C C NEED TO PRINT & CLEAR LBUFF IF (IPRINT .EQ. 0) TYPE 122,(LBUFF(J),J=1,79) IF (IPRINT .EQ. 1) WRITE (PR,122) (LBUFF(J),J=1,79) 122 FORMAT (1X,80A1) DO 23 I=1,80 LBUFF(I) = ' ' 23 C O N T I N U E IBFPTR = 0 C 24 C O N T I N U E IF (IPRINT .EQ. 1) GOTO 25 TYPE 122,LBUFF TYPE *,'TOTAL BYTES = ',ITOTAL,'K' GOTO 10 C 25 WRITE (PR,122) LBUFF WRITE (PR,*) 'TOTAL BYTES = ',ITOTAL,'K' CLOSE (UNIT=PR,DISP='PRINT') GOTO 10 C 26 CONTINUE STOP 'LP- ERROR' C C COPY A FILE FROM CP/M DISK C C GET CP/M NAME 30 CALL GTCPMF(CNAME) IF (CNAME(1).EQ.'*'.AND.CNAME(9).EQ.'*') GO TO 40 ! *.* IF (CNAME(1).NE.'*') GO TO 35 ICPL = 10 ! FNAME.* ICPH = 12 GO TO 40 35 CONTINUE IF (CNAME(9).NE.'*') GO TO 36 ICPL = 2 ! *.EXT ICPH = 9 GO TO 40 36 CONTINUE CALL GETDIR(ICHAN) C C LOOKUP CNAME IN DISK DIR CALL FIND(CNAME,0,IENTRY,-2,12) IF (IENTRY .NE. -1) GOTO 32 !OK 31 CONTINUE TYPE *,'FILE NOT FOUND' GOTO 10 C C GET DEC NAME & OPEN 32 CALL GETFN('OUTPUT',IDCHAN,CNAME,MODE) C READ FILE AND WRITE TO DEC CALL CPYFIL(IENTRY,CNAME,ICHAN,IDCHAN,MODE(1)) C C CPYFIL CLOSES AND FREES THE CHANNEL 34 TYPE *,'COPY COMPLETED' GOTO 10 C C C COPY ALL FILES FROM CP/M DISK TO PDP11-DISK: 40 CONTINUE CALL GETDIR(ICHAN) DO 48 IENTRY=1,64 IF (DIR(1,IENTRY) .EQ. EMPT) GOTO 48 IF (DIR(13,IENTRY) .NE. 0) GOTO 48 IF (ICPL.EQ.2.AND.ICPH.EQ.12) GO TO 41 IENT = IENTRY CALL FIND(CNAME,0,IENT,ICPL,ICPH) IF (IENT .EQ. -1) GOTO 48 !OK 41 CONTINUE DO 42 IPTR=2,12 CNAME(IPTR-1)=DIR(IPTR,IENTRY) !SAVE NAME 42 C O N T I N U E C NOW CONVERT CNAME INTO DEC NAME, IN DNAME CALL TRFN(CNAME,DNAME) C NOW OPEN DEC FILE (AS CHANNEL IDCHAN) CALL DECOPN(DNAME,IDCHAN,'O',MODE) IFILE=IENTRY CALL CPYFIL(IFILE,CNAME,ICHAN,IDCHAN,MODE(1)) 48 C O N T I N U E GOTO 34 C C C INITIALIZE A CP/M DISK 50 TYPE *,'INITIALIZE--ARE YOU SURE?' ACCEPT 126,IWANT 126 FORMAT(A1) IF (IWANT .NE. 'Y') GOTO 10 C C (WRITE E5H THROUGHOUT DIRECTORY) DO 54 I=1,32 DO 52 J=1,64 DIR(I,J)=EMPT 52 C O N T I N U E 54 C O N T I N U E 56 CALL PUTDIR(ICHAN) TYPE *,'COMPLETED' GOTO 10 C C C DELETE A CP/M FILE 60 CALL GTCPMF(CNAME) CALL ERASE(CNAME,ICHAN,IST) IF (IST .EQ. -1) GOTO 31 !UNSUCCESSFUL GOTO 56 !WRITE DIR & RET TO MENU C C C TOGGLE COPY MODE 62 IF (MODE(1) .EQ. 'A') GOTO 64 MODE(1) = 'A' MODE(2) = 'S' MODE(3) = 'C' MODE(4) = 'I' MODE(5) = 'I' MODE(6) = ' ' GOTO 10 C 64 MODE(1) = 'B' MODE(2) = 'I' MODE(3) = 'N' MODE(4) = 'A' MODE(5) = 'R' MODE(6) = 'Y' GOTO 10 C C C WRITE A CP/M FILE C GET DEC NAME & OPEN 70 CALL GETFN('INPUT ',IDCHAN,CNAME,MODE) IDBLK=0 C get starting address for QIO CALL GETADR(LP(1),DBUFF(1)) C GET CP/M FILE NAME CALL GTCPMF(CNAME) C C IF WE ALREADY HAVE A FILE BY THIS NAME, ERASE IT CALL ERASE(CNAME,ICHAN,IST) C C NOW FOR THE HARD PART. C WE MUST READ THE CP/M DIRECTORY; MAKE A BIT MAP C (ACTUALLY BYTE MAP) OF CLUSTERS USED; CREATE A C CP/M DIRECTORY ENTRY; ASSIGN EACH CLUSTER, READ C 8*128 BYTES WITH IREADW AND WRITE THEM TO THE C CP/M DISK. C DO 72 I=1,64 IF (DIR(1,I) .EQ. EMPT) GOTO 72 !NOT ALLOCATED DO 71 J=17,32 IDIREN=DIR(J,I) IF (IDIREN .EQ. 0) GOTO 72 !NOT ALLOCATED IF (IDIREN .LT. 0) IDIREN = IDIREN+256 IF (IDIREN .LT.0 .OR. IDIREN .GT. 255) STOP 'MAP ERROR' BITMAP (IDIREN+1) = 1 71 C O N T I N U E 72 C O N T I N U E C C NOW FIND AN OPEN DIR ENTRY IEXT=0 73 DO 74 IENTRY=1,64 IF (DIR(1,IENTRY) .EQ. EMPT) GOTO 75 74 C O N T I N U E STOP 'DIRECTORY FULL' C C COPY IN FILE NAME 75 DIR(1,IENTRY)=0 DO 76 J=2,12 DIR(J,IENTRY)=CNAME(J-1) 76 C O N T I N U E DO 77 J=13,32 DIR(J,IENTRY)=0 77 C O N T I N U E IBLK=1 ISIZE=0 DIR(13,IENTRY)=IEXT C C ALLOCATE A CLUSTER 78 DO 79 ICLU=3,241 IF (BITMAP(ICLU) .EQ. 0) GOTO 80 !FOUND A FREE CLUSTER 79 C O N T I N U E STOP 'CP/M DISK FULL' C C WRITE CLUSTER NUMBER TO DIRECTORY 80 BITMAP(ICLU)=1 ICLU=ICLU-1 !0-255 NOT 1-256 DIR(IBLK+16,IENTRY)=ICLU C CONVERT CLUSTER # TO SECTOR AND TRACK ITEMP=8*ICLU ISTTRK=ITEMP/26 ISTART=ITEMP-26*ISTTRK+1 ISTTRK=ISTTRK+2 C C READ 8 SECTORS FROM DEC DISK LP(5) = IDBLK C read virtual block from RSX-file CALL WTQIO("10400,IDCHAN,IDCHAN,,LS,LP,LD) I = ISTAT(LS,LD,10) IF (LS(1).EQ.-10) GO TO 97 IDBLK=IDBLK+2 IF (LS(2).EQ.256) GO TO 96 ! one block IF (LS(2).GE.0) GO TO 81 ! STOP C C WRITE 8 SECTORS 81 ILIMIT=7 83 IF (MODE(1) .EQ. 'B') GOTO 93 C C FIND EOF, INSERT CTL-Z (CP/M EOF) DO 84 INDEX2=128*(ILIMIT+1),1,-1 IF (DBUFF(INDEX2) .NE. 0) GOTO 85 84 C O N T I N U E 85 IF (INDEX2 .LT. 128*(ILIMIT+1)) DBUFF(INDEX2+1) = 26 !CTL-Z C 93 DO 95 ISEC=0,ILIMIT ITEMP=ISTART+ISEC ITRK=ISTTRK IF (ITEMP .LE. 26) GOTO 94 ITEMP=ITEMP-26 ITRK=ITRK+1 94 CALL DOSEC('W',ITRK,ITEMP,DBUFF(128*ISEC+1),ICHAN) ISIZE=ISIZE+1 95 C O N T I N U E IF (IRET .EQ. 0) GOTO 97 C C NEED ANOTHER CLUSTER IBLK=IBLK+1 IF (IBLK .LE. 16) GOTO 78 C NEED A NEW EXTENT DIR(16,IENTRY)=128 !SET SECTOR COUNT IEXT=IEXT+1 TYPE *,'WORKING. . .' GOTO 73 C C ONLY 4 SECTORS READ FROM DEC FILE 96 ILIMIT=3 IRET=0 GOTO 83 C C THAT'S ALL 97 DIR(16,IENTRY)= ISIZE !SET SIZE C WRITE OUT DIRECTORY CALL PUTDIR(ICHAN) CLOSE (UNIT=IDCHAN) ! close output file GOTO 34 C C C regular exit from program 99 CONTINUE STOP END SUBROUTINE GETDIR(ICHAN) C**************************************************** C* * C* READ DIRECTORY OF CP/M DISK. * C* * C* THE CP/M DISK USES TRACKS 0 AND 1 FOR SYSTEM * C* TRACKS; WE MAY IGNORE THEM. THE DIRECTORY IS * C* 2K OR 16 SECTORS, STARTING ON TRACK 2. * C* * C* RUSS BAKKE 05-06-82 * C* * C**************************************************** C BYTE DIR(32,64) COMMON DIR C DO 80 INDEX=1,16 ISECTR=INDEX CALL DOSEC('R',2,ISECTR,DIR(1,4*(ISECTR-1)+1),ICHAN) 80 C O N T I N U E RETURN END C SUBROUTINE PUTDIR(ICHAN) C**************************************************** C* * C* WRITE DIRECTORY OF CP/M DISK. * C* (SIMILAR TO GETDIR). * C* * C* RUSS BAKKE 05-25-82 * C* * C**************************************************** C BYTE DIR(32,64) COMMON DIR C DO 80 INDEX=1,16 ISECTR=INDEX CALL DOSEC('W',2,ISECTR,DIR(1,4*(ISECTR-1)+1),ICHAN) 80 C O N T I N U E RETURN END C SUBROUTINE DOSEC(RW,ITRK,ISEC,BUFF,ICHAN) C**************************************************** C* * C* READ/WRITE (RW IS DIRECTION) LOGICAL SECTOR * C* 'ISEC', TRACK 'ITRK', TO/FROM 'BUFF' (128 * C* BYTES), FROM/TO CHANNEL 'ICHAN'. * C* * C* RUSS BAKKE 05-12-82 * C* * C**************************************************** C INTEGER BLCK DIMENSION IS(2), LS(2), IP(6), LP(6) C BYTE BUFF(128),MYBUFF(130),RW INTEGER ITABLE(26) C COMMON /IOBL/IS,IP,LS,LP C DATA ITABLE /1,7,13,19,25,5,11,17,23,3,9,15,21,2,8, + 14,20,26,6,12,18,24,4,10,16,22/ C C ITABLE IS THE CP/M SECTOR INTERLEAVE TABLE (26 SECTORS PER TRACK) C PHYSICAL SECTOR # [1..26] = ITABLE(LOGICAL SECTOR # [1..26]) C CALL GETADR(IP(1),BUFF(1)) ! address for QIO C driver needs block number -1 BLCK = ITRK*26 + ITABLE(ISEC) - 1 ! calculate block number on disk IP(5) = BLCK ! put into parameter block for QIO IF (RW.EQ.'W') GO TO 50 C read physcal block from floppy CALL WTQIO("1040,ICHAN,ICHAN,,IS,IP,ID) BLCK = BLCK + 10000 I = ISTAT(IS,ID,BLCK) D TYPE 210, ITRK, ISEC, BLCK D210 FORMAT ( 3I10 ) CTEST TYPE 200, (BUFF(I),I=1,16) 200 FORMAT ( 16O4 ) C C WRITING 50 CONTINUE C write physical block onto floppy CALL WTQIO("440,ICHAN,ICHAN,,IS,IP,ID) BLCK = BLCK + 20000 I = ISTAT(IS,ID,BLCK) RETURN END C SUBROUTINE GTCPMF(CNAME) C**************************************************** C* * C* GET CP/M NAME, AND FORMAT INTO CNAME. * C* * C* RUSS BAKKE 05-05-82 * C* * C**************************************************** C BYTE CNAME(12),TYPE(3) C TYPE *,'ENTER CP/M FILE NAME:' ACCEPT 110,CNAME 110 FORMAT(12A1) C C NOW REFORMAT TO 8 CHAR NAME & 3 CHAR TYPE DO 10 INDEX=1,12 IF (CNAME(INDEX) .EQ. '.') GOTO 20 10 C O N T I N U E GOTO 90 !NO '.', PASS WHAT WE GOT C C EXTRACT FILE TYPE 20 DO 30 INDEX2=1,3 TYPE(INDEX2) = CNAME(INDEX+INDEX2) 30 C O N T I N U E C FILL CNAME FROM PERIOD THROUGH 12 WITH SPACES DO 40 INDEX2=INDEX,12 CNAME(INDEX2) = ' ' 40 C O N T I N U E C COPY TYPE INTO CNAME DO 50 INDEX2=1,3 IF (TYPE(INDEX2) .EQ. 0) GOTO 90 CNAME(8+INDEX2) = TYPE(INDEX2) 50 C O N T I N U E 90 RETURN END C SUBROUTINE GETFN(PROMPT,IDCHAN,CNAME,MODE) C******************************************************** C* * C* INPUT A FILE NAME AND OPEN A DEC FILE. RETURN THE * C* CHANNEL NUMBER IN IDCHAN. * C* * C* RUSS BAKKE 05-11-82 * C* * C******************************************************** C LOGICAL*1 FNAME(30),PROMPT(6) BYTE CNAME(12),MODE C 5 TYPE 103, PROMPT 103 FORMAT (1X,6A1,' file specification' / 1 ' blank = take CP/M-name : ' $ ) C 8 ACCEPT 105, FNAME 105 FORMAT (30A1) FNAME(16)=0 C CHECK TO AVOID NULL FILE NAME IF (FNAME(1) .EQ. ' ') GOTO 80 IF (FNAME(3) .EQ. ':' .AND. FNAME(4) .EQ. ' ') GOTO 70 IF (FNAME(4) .EQ. ':' .AND. FNAME(5) .EQ. ' ') GOTO 70 C 60 CONTINUE CALL DECOPN(FNAME,IDCHAN,PROMPT(1),MODE) RETURN C 70 TYPE *,'ERROR IN FILE SPECIFICATION, TRY AGAIN' GOTO 5 C C BLANK GIVEN, TAKE CP/M-NAME 80 CONTINUE CALL TRFN(CNAME,FNAME) GO TO 60 END SUBROUTINE TRFN(CNAME,DNAME) C C PUT CP/M-FILENAME INTO DECFILENAME C BYTE CNAME(12),DNAME(30) C NOW CONVERT CNAME INTO DEC NAME, IN DNAME DO 44 IPTR=1,8 IF (CNAME(IPTR) .EQ. ' ') GOTO 46 DNAME(IPTR) = CNAME(IPTR) 44 C O N T I N U E 46 DNAME(IPTR)='.' DNAME(IPTR+1) = CNAME(9) DNAME(IPTR+2) = CNAME(10) DNAME(IPTR+3) = CNAME(11) DNAME(IPTR+4) = 0 C TYPE 124,(CNAME(J),J=1,11),(DNAME(J),J=1,16) 124 FORMAT (1X,'COPYING CP/M FILE ',8A,'.',3A,' TO DEC FILE ',16A) END SUBROUTINE FIND(CNAME,EXT,IENTRY,ICPL,ICPH) C**************************************************** C* * C* FIND CP/M FILE NAMED CNAME IN DIRECTORY (IN * C* DIR, PASSED IN COMMON), EXTENT 'EXT'; RETURN * C* DIRECTORY ENTRY NUMBER IN IENTRY. * C* * C* RUSS BAKKE 05-11-82 * C* * C**************************************************** C BYTE DIR(32,64),CNAME(12) BYTE EMPT,EXTB DATA EMPT/"345/ INTEGER EXT COMMON DIR C ISW = 1 EXTB = EXT ICPLI = ICPL IF (ICPL.GT.0) GO TO 11 ICPLI = 2 ISW = 0 IENTRY = 1 11 CONTINUE C DO 44 IENTRY = 1,64 IF (DIR(1,IENTRY) .EQ. EMPT) GOTO 44 !EMPTY, SKIP DO 42 ICHAR=ICPLI,ICPH IF (DIR(ICHAR,IENTRY) .NE. CNAME(ICHAR-1)) GOTO 44 42 C O N T I N U E C FALL THROUGH MEANS A MATCH IF (DIR(13,IENTRY) .EQ. EXTB) GOTO 90 !FOUND IT C 44 C O N T I N U E IF(ISW.EQ.1) GO TO 45 IENTRY = IENTRY + 1 IF (IENTRY.LE.64) GO TO 11 ! WE ARE IN THE DO LOOP 45 CONTINUE C FALL THROUGH MEANS NO MATCH FOUND IENTRY=-1 90 CONTINUE RETURN END SUBROUTINE DECOPN(FNAME,IDCHAN,RW,MODE) C************************************************** C* * C* OPEN A DEC FILE FNAME, RETURNING CHANNEL * C* NUMBER IN IDCHAN. RW IS READ/WRITE. * C* * C* RUSS BAKKE 05-25-82 * C* * C************************************************** C BYTE FNAME(30),RW,MODE REAL*8 FSPEC C C last byte of FNAME must be 0 for OPEN DO 20 I=1,30 IF (FNAME(I).NE.' ') GO TO 20 GO TO 21 20 CONTINUE 21 FNAME(I) = 0 IF (RW.EQ.'O') GO TO 50 C C open read-file C IF (MODE.EQ.'A') GO TO 40 OPEN(UNIT=IDCHAN,NAME=FNAME,TYPE='OLD',ERR=45 1 ,BLOCKSIZE=1024,FORM='UNFORMATTED') RETURN 40 CONTINUE OPEN(UNIT=IDCHAN,NAME=FNAME,TYPE='OLD',ERR=45) RETURN C 45 TYPE 100, FNAME 100 FORMAT ( ' open error for : ' 31A1 ) STOP C C open write-file 50 CONTINUE IF (MODE.EQ.'A') GO TO 55 OPEN (UNIT=IDCHAN,NAME=FNAME,TYPE='NEW',ERR=45 1 ,BLOCKSIZE=1024,FORM='UNFORMATTED' 2 ,INITIALSIZE=10,EXTENDSIZE=6) RETURN 55 CONTINUE OPEN (UNIT=IDCHAN,NAME=FNAME,TYPE='NEW',ERR=45) RETURN C END SUBROUTINE CPYFIL(IENTRY,CNAME,ICHAN,IDCHAN,MODE) C************************************************* C* * C* COPY CP/M FILE (ICHAN) TO DEC FILE (IDCHAN). * C* CP/M DIRECTORY ENTRY IS 'IENTRY'. * C* MODE IS "BINARY" OR "ASCII ". * C* CLOSE DEC CHANNEL (IDCHAN) WHEN FINISHED. * C* * C* RUSS BAKKE 02-02-83 * C* * C************************************************* C BYTE DIR(32,64),DBUFF(1024),CNAME(12),MODE COMMON DIR COMMON /IOBL/ IS(2), IP(6), LS(2), LP(6) C IDBLK=1 !DISK BLOCK TO WRITE IEXT=0 !FIRST EXTENT CALL GETADR(LP(1),DBUFF(1)) C 8 ICLU=1 !FIRST CLUSTER ISIZE=DIR(16,IENTRY) IF (ISIZE .LT. 0) ISIZE=ISIZE+256 IF (ISIZE .EQ. 128) ISIZE=129 !DON'T LET IT COUNT OUT IF (MODE.EQ.'A') GO TO 2 C need to do this only for BINARY writes TYPE *, '##### NO A #####' C C we will use the WTQIO for writing our data, C in BINARY mode C in order to avoid additional bytes from C FORTRAN I/O-blocking C therefore we need to preformat the file: C INUM = ISIZE / 8 IF (INUM*8.LT.ISIZE) INUM = INUM + 1 DO 1 I=1,INUM WRITE (IDCHAN) DBUFF 1 CONTINUE C 2 CONTINUE 10 CONTINUE D TYPE 300, ISIZE D300 FORMAT ( ' ISIZE ' I7 ) IF (ISIZE .EQ. 0) GOTO 90 IBLK=DIR(16+ICLU,IENTRY) IF (IBLK .LT. 0) IBLK=IBLK+256 C (PROBLEM HERE, IS WE GET SIGN EXTENSION ON READING BYTE C VALUE INTO INTEGER VARIABLE) D TYPE 310, IBLK D310 FORMAT ( ' IBLK ' I7 ) IF (IBLK .EQ. 0) GOTO 90 !THAT'S ALL C C NEED TO READ 'IBLK' 1K CLUSTER (8 SECTORS) C C CONVERT IBLK TO STARTING SECTOR # AND TRACK # C MULTIPLY BY 8 AND REDUCE MODULO 26 ITEMP=8*IBLK ISTTRK=ITEMP/26 ISTART=ITEMP-26*ISTTRK+1 ISTTRK=ISTTRK+2 !SKIP SYSTEM TRACKS D TYPE 320, ISTART, ISTTRK D320 FORMAT ( ' ISTART, ISTARTTRK ' 2I7 ) C DO 60 ISECTR=0,7 ITEMP=ISTART+ISECTR ITRK=ISTTRK IF (ITEMP .LE. 26) GOTO 30 ITEMP=ITEMP-26 ITRK=ITRK+1 30 CALL DOSEC('R',ITRK,ITEMP,DBUFF(128*ISECTR+1),ICHAN) ISIZE=ISIZE-1 IF (ISIZE .LE. 0) GOTO 80 60 C O N T I N U E C C NOW WRITE BUFF TO IDCHAN C SEARCH BUFFER FOR CTL-Z (EOF) UNLESS BINARY MODE. IF (MODE .EQ. 'B') GOTO 70 62 CONTINUE D TYPE *, ' ***** 62 ***** ' DO 65 INDEX=1,1024 IF (DBUFF(INDEX) .EQ. 26) GOTO 75 65 C O N T I N U E C 70 CONTINUE LP(5) = IDBLK D TYPE *, ' ***** 70 ***** ', LP IF (MODE.EQ.'A') CALL WTF(DBUFF,IDCHAN) IF (MODE.EQ.'B') CALL WTQIO("11000,IDCHAN,IDCHAN,,LS,LP,LD) I = ISTAT(LS,LD,70) IDBLK=IDBLK+2 ICLU=ICLU+1 IF (ICLU .LT. 17) GOTO 10 !NEXT SEGMENT C C NOW SEE IF WE HAVE ANOTHER EXTENT IEXT=IEXT+1 CALL FIND(CNAME,IEXT,IENTRY,-2,12) IF (IENTRY .NE. -1) GOTO 8 !NEXT EXTENT GOTO 90 C C HAVE EOF AT "INDEX" 75 CONTINUE D TYPE *, ' ***** 75 ***** ' DO 78 INDEX1=INDEX,1024 DBUFF(INDEX1)=0 !NULL FILL FOR DEC 78 C O N T I N U E IF (INDEX .LE. 512) GOTO 83 GOTO 84 C C HAVE PARTIAL BUFFER--WRITE IT OUT. 80 CONTINUE D TYPE *, ' ***** 80 ***** ' IF (MODE .EQ. 'A') GOTO 62 IF (ISECTR.EQ.7) GO TO 84 ! NOTHING TO ZERO DO 82 IPTR=128*(ISECTR+1)+1,1024 DBUFF(IPTR)=0 82 C O N T I N U E IF (ISECTR .GT. 3) GOTO 84 83 CONTINUE LP(2) = 512 LP(5) = IDBLK D TYPE *, ' ***** 83 ***** ', LP IF (MODE.EQ.'A') CALL WTF(DBUFF,IDCHAN) IF (MODE.EQ.'B') CALL WTQIO("11000,IDCHAN,IDCHAN,,LS,LP,LD) I = ISTAT(LS,LD,77) LP(2) = 1024 IDBLK=2 GOTO 86 C 84 CONTINUE D TYPE *, IDBLK LP(5) = IDBLK D TYPE *, ' ***** 84 ***** ', LP IF (MODE.EQ.'A') CALL WTF(DBUFF,IDCHAN) IF (MODE.EQ.'B') CALL WTQIO("11000,IDCHAN,IDCHAN,,LS,LP,LD) I = ISTAT(LS,LD,80) IDBLK=3 86 CONTINUE D TYPE *, ' ***** 86 ***** ' 90 IF (IDBLK .EQ. 1) GOTO 94 92 CONTINUE D TYPE *, ' ***** 92 ***** ' CLOSE (UNIT=IDCHAN) ! close file RETURN C C FILE OF 0 LENGTH, EAT IT. 94 CONTINUE CLOSE (UNIT=IDCHAN,DISP='DELETE') RETURN END C SUBROUTINE WTF(DB,IDCHAN) C C WRITE DBUFF TO FILE C AS FORMATTED DATA C C EDIT #1 FROM 23/10/84 BY: H.K. C IMPLICIT INTEGER (A-Z) BYTE DB(1024), Z(130) C IF (P.EQ.0) P = 1 DO 19 I=1,1024 IF (DB(I).EQ."32) GO TO 20 ! EOF IF (DB(I).EQ."15) GO TO 12 ! CR IF (DB(I).EQ."12) GO TO 13 ! LF 11 CONTINUE Z(P) = DB(I) P = P + 1 IF (P.GT.130) GO TO 12 GO TO 18 12 CONTINUE WRITE (IDCHAN,100) (Z(L),L=1,P-1) P = 1 GO TO 18 13 CONTINUE IF (DB(I-1).EQ."15) GO TO 18 ! LF AFTER CR, IGNORE GO TO 11 18 CONTINUE 19 CONTINUE RETURN ! P CHARS IN Z ARE REST 20 CONTINUE IF (P.GT.1) WRITE (IDCHAN,100) (Z(L),L=1,P-1) P = 1 RETURN 100 FORMAT ( 1X, 130A1 ) END C C SUBROUTINE ERASE (CNAME,ICHAN,ISTAT) C**************************************************** C* * C* ERASE CP/M FILE 'CNAME' VIA CHANNEL ICHAN. * C* RET ISTAT=0 IF OK, ELSE -1. * C* * C* RUSS BAKKE 12-07-82 * C* * C**************************************************** C BYTE DIR(32,64),CNAME(12) BYTE EMPT DATA EMPT/"345/ COMMON DIR C CALL GETDIR(ICHAN) CALL FIND(CNAME,0,IENTRY,-2,12) IF (IENTRY .EQ. -1) GOTO 50 !UNSUCCESSFUL IEXT=0 10 DIR (1,IENTRY)=EMPT !SET EMPTY IEXT=IEXT+1 CALL FIND(CNAME,IEXT,IENTRY,-2,12) !MORE EXTENTS? IF (IENTRY .NE. -1) GOTO 10 !YES ISTAT=0 RETURN C 50 ISTAT=-1 !UNSUCCESSFUL RETURN END FUNCTION ISTAT(S,D,I) C ########################### C # C ERROR PROCESSING ROUTINE # C for QIO's # C # C ########################### C IMPLICIT INTEGER (A-Z) C DIMENSION S(2) BYTE SB(2) C EQUIVALENCE (S1,SB(1)) C ISTAT = 0 S1 = S(1) ! status, postiv for successful return S1 = SB(1) ! status only in one byte, do it into an integer IF (S1.GE.0.AND.D.GE.0) RETURN ! OK!!!! S(1) = S1 TYPE 10,I,D,S,D,S STOP 'ISTAT' 10 FORMAT ( 2X, 'ERROR DURING B# ' I5 , / 1 ' DIR-, I/O-STATUS:' / 3I7, 3O7 ) END