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
	PROGRAM CPMDEC
C
	BYTE DIR(32,64),CNAME(12),DNAME(16),LBUFF(80)
	BYTE BITMAP(256),DBUFF(1024),MODE(6)
	COMMON DIR
	DATA DNAME/ 'D','Y','0',':',12*0/
	DATA BITMAP/ 2*1,254*0/, MODE /'A','S','C','I','I',' '/
C
	TYPE 100
  100	FORMAT (1X,'CP/M DISK READER, V1.0'//
     +	1X,'INSERT CP/M DISK IN DY1: AND PRESS RETURN'/)
	ACCEPT 104,IWANT
C
C OPEN CP/M DISK AS NON-FILE STRUCTURED DEVICE:
	CALL DSKOPN(ICHAN)
C
C
   10	IPRINT=0
	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,'4.  COPY ALL FILES FROM CP/M DISK TO DY0:',/,
     +	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.')
	ACCEPT 104,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
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. "345) 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)
	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
	IF (IPRINT .EQ. 1) PRINT 122,LBUFF
  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	PRINT 122,LBUFF
	PRINT *,'TOTAL BYTES = ',ITOTAL,'K'
	GOTO 10
C
C COPY A FILE FROM CP/M DISK
C
C GET CP/M NAME
   30	CALL GTCPMF(CNAME)
	CALL GETDIR(ICHAN)
C
C  LOOKUP CNAME IN DISK DIR
	CALL FIND(CNAME,0,IENTRY)
	IF (IENTRY .NE. -1) GOTO 32	!OK
   31	TYPE *,'FILE NOT FOUND'
	GOTO 10
C
C  GET DEC NAME & OPEN
   32	CALL GETFN('OUTPUT',IDCHAN)
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 DY0:
   40	TYPE *,'INSERT BLANK DEC DISK IN DY0: AND PRESS RETURN'
	ACCEPT 104,IWANT
	CALL GETDIR(ICHAN)
	DO 48 IENTRY=1,64
	IF (DIR(1,IENTRY) .EQ. "345) GOTO 48
	IF (DIR(13,IENTRY) .NE. 0) GOTO 48
	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
	DO 44 IPTR=1,6
	IF (CNAME(IPTR) .EQ. ' ') GOTO 46
	DNAME(IPTR+4) = CNAME(IPTR)
   44	C O N T I N U E
   46	DNAME(IPTR+4)='.'
	DNAME(IPTR+5) = CNAME(9)
	DNAME(IPTR+6) = CNAME(10)
	DNAME(IPTR+7) = CNAME(11)
	DNAME(IPTR+8) = 0
	DNAME(4)=':'
C
	TYPE 124,(CNAME(J),J=1,11),DNAME
  124	FORMAT (1X,'COPYING CP/M FILE ',8A,'.',3A,'  TO DEC FILE ',16A)
C
C  NOW OPEN DEC FILE (AS CHANNEL IDCHAN)
	CALL DECOPN(DNAME,IDCHAN,'O')
	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)="345
   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,ISTAT)
	IF (ISTAT .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)
	IDBLK=0
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,ISTAT)
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. "345) 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. "345) 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
	IRET=IREADW(512,DBUFF,IDBLK,IDCHAN)
	IDBLK=IDBLK+2
C  ERRORS ARE:
C  -1: EOF
C  -2: HARDWARE ERROR
C  -3: CHANNEL NOT OPEN
C  OR IF IRET = 256, ONLY 1 BLOCK READ
	IF (IRET .EQ. 256) GOTO 96	!1 BLOCK
	IF (IRET .GE. 0) GOTO 81
	IF (IRET .EQ. -1) GOTO 97	!EOF
	TYPE *,'IREAD ERROR TYPE ',IRET
	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)
	CALL ICLOSE(IDCHAN)
	CALL IFREEC(IDCHAN)
	GOTO 34
C
C
C  CLOSE
   99	CALL ICLOSE (ICHAN)
	CALL IFREEC (ICHAN)
	CALL EXIT
	END
C
	SUBROUTINE DSKOPN (IDCH)
C****************************************************
C*                                                  *
C*  OPEN FLOPPY DISK DRIVE 1 AS NON-FILE            *
C*  STRUCTURED DEVICE; RETURN CHANNEL NO. IN IDCH.  *
C*                                                  *
C*  RUSS BAKKE                      02-10-83        *
C*                                                  *
C****************************************************
C
	REAL*4 DISK1
	DATA DISK1 /3RDY1   /
C
C  FETCH HANDLER, OPEN A CHANNEL, LOOKUP DEVICE
	IF (IFETCH(DISK1) .NE. 0) STOP 'IFETCH ERROR
     +	IN DSKOPN'
	IDCH=IGETC()
	IF(IDCH.LT.0) STOP' NO CHANNEL AVAILABLE'
C
	IRET = LOOKUP(IDCH,DISK1)
	IF (IRET .GE. 0) GOTO 10
C
C  LOOKUP FAILURE
	TYPE *,'LOOKUP FAILURE TYPE ',IRET
	STOP
C
   10	RETURN
	END
C
	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
	BYTE BUFF(128),MYBUFF(130),RW
	INTEGER ITABLE(26)
	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  ITABLE IS THE CP/M SECTOR INTERLEAVE TABLE (26 SECTORS PER TRACK)
C  PHYSICAL SECTOR # [1..26] = ITABLE(LOGICAL SECTOR # [1..26])
C
	IF (RW .EQ. 'W') GOTO 50
	IRET=ISPFNW("377,ICHAN,ITRK,MYBUFF,ITABLE(ISEC))
C
C  THE ISPFNW CALL IS AS FOLLOWS:
C  IRET=ISPFNW(FUNC,ICHAN,ITRK,BUFF,SECTOR)
C    FUNC="377 FOR READ, "376 FOR WRITE
C    ICHAN=CHANNEL #, FROM LOOKUP
C    ITRK=ABSOLUTE PHYSICAL TRACK #, 0..76
C    SECTOR=ABSOLUTE PHYSICAL SECTOR #, 1..26
C    BUFF=128 BYTE BUFFER
C    IRET RETURNS:
C	0 NORMAL
C	1  EOF
C	2  HARDWARE ERROR
C	3  CHANNEL NOT OPEN
C
	IF (IRET .EQ. 0) GOTO 40
   30	TYPE 100,RW,ITRK,ISEC
  100	FORMAT (1X,A,2X,'TRACK: ',I3,'   LOG. SECTOR: ',I3)
	IF (IRET .EQ. 1) STOP 'CHANNEL EOF IN DOSEC'
	IF (IRET .EQ. 2) STOP 'HARDWARE ERROR IN DOSEC'
	IF (IRET .EQ. 3) STOP 'CHANNEL NOT OPEN IN DOSEC'
	STOP 'ERROR IN DOSEC'
C
C  WE MUST READ INTO 130 BYTE BUFFER, BECAUSE ISPFNW READS
C  LEADING 0 WORD INTO BUFFER.  (THIS IS DOCUMENTED IN THE
C  SOFTWARE SUPPORT MANUAL BUT NOT IN THE PROGRAMMER'S REFERENCE).
   40	DO 45 I=1,128
	BUFF(I) = MYBUFF(I+2)
   45	C O N T I N U E
	RETURN
C
C  WRITING
   50	DO 55 I=1,128
	MYBUFF(I+2)=BUFF(I)
   55	C O N T I N U E
	MYBUFF(1)=0
	MYBUFF(2)=0
C
	IRET=ISPFNW("376,ICHAN,ITRK,MYBUFF,ITABLE(ISEC))
	IF (IRET .NE. 0) GOTO 30
	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
C  FIND '.'
	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)
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(16),PROMPT(6)
C
    5	WRITE (7,103) PROMPT
  103	FORMAT (1X,6A1,' FILE SPECIFICATION?')
C
    8	READ (5,105) FNAME
  105	FORMAT (16A1)
	FNAME(16)=0
C	CHECK TO AVOID NULL FILE NAME
	IF (FNAME(1) .EQ. ' ') GOTO 70
	IF (FNAME(3) .EQ. ':' .AND. FNAME(4) .EQ. ' ') GOTO 70
	IF (FNAME(4) .EQ. ':' .AND. FNAME(5) .EQ. ' ') GOTO 70
C
	CALL DECOPN(FNAME,IDCHAN,PROMPT(1))
	RETURN
C
   70	TYPE *,'ERROR IN FILE SPECIFICATION, TRY AGAIN'
	GOTO 5
	END
C
	SUBROUTINE DECOPN(FNAME,IDCHAN,RW)
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(16),RW
	REAL*8 FSPEC
C
C  CONVERT FNAME TO RADIX 50
C
C  REFORMAT AS DL0FNAME_TYP
C  FIRST FIND ':'
	DO 20 I=1,16
	IF (FNAME(I) .EQ. ':') GOTO 25
   20	C O N T I N U E
C  NO ':' FOUND, INSERT 'DL0'
	DO 22 I=13,1,-1
	FNAME(I+3)=FNAME(I)
   22	C O N T I N U E
	FNAME(1)='D'
	FNAME(2)='L'
	FNAME(3)='0'
	GOTO 30
C
C  EAT THE ':'
  25	DO 28 J=I,15
	FNAME(J)=FNAME(J+1)
   28	C O N T I N U E
	FNAME(16)=' '
C
C  NOW FIND '.'
   30	DO 35 I=1,16
	IF (FNAME(I) .EQ. '.') GOTO 36
   35	C O N T I N U E
C  NO '.' FOUND
	GOTO 40
C
C  MOVE TYPE TO LAST 3 CHARS
   36	FNAME(16)=FNAME(I+3)
	FNAME(15)=FNAME(I+2)
	FNAME(14)=FNAME(I+1)
	FNAME(10)=FNAME(14)
	FNAME(11)=FNAME(15)
	FNAME(12)=FNAME(16)
C
C  BLANK FILL
	IF (I .GE. 10) GOTO 40
	DO 38 J=I,9
	FNAME(J)=' '
   38	C O N T I N U E
C
C  CHANGE ALL ILLEGAL CHARACTERS TO '9'
   40	DO 42 INDEX=4,12
	IF (FNAME(INDEX) .GE. 'A' .AND.
     +	FNAME(INDEX) .LE. 'Z') GOTO 42		!OK
	IF (FNAME(INDEX) .GE. '0' .AND.
     +	FNAME(INDEX) .LE. '9') GOTO 42		!OK
	IF (FNAME(INDEX) .EQ. ' ' .OR.
     +	FNAME(INDEX) .EQ. '.') GOTO 42		!OK
	FNAME(INDEX) = '9'
   42	C O N T I N U E
C
C  NOW CONVERT TO RADIX 50
	IDUM=IRAD50(12,FNAME,FSPEC)
C
C  GET A CHANNEL
	IDCHAN=IGETC()
	IF(IDCHAN .LT. 0) STOP' NO CHANNEL AVAILABLE'
C
	IF (RW .EQ. 'O') GOTO 50
	IRET = LOOKUP(IDCHAN,FSPEC)
	IF (IRET .GE. 0) GOTO 90
C
C  LOOKUP FAILURE--TYPES ARE:
C  -1: CHANNEL ALREADY OPEN
C  -2: SPECIFIED FILE NOT FOUND
C  -3: DEVICE IN USE
C  -4: TAPE ONLY
	IF (IRET .NE. -2) GOTO 45
	STOP 'DEC FILE NOT FOUND'
C
   45	TYPE *,'LOOKUP FAILURE TYPE ',IRET
	STOP
C
C  WRITE FILE MUST USE IENTER NOT LOOKUP
   50	IRET=IENTER(IDCHAN,FSPEC,-1)
	IF (IRET .GE. 0) GOTO 90
C  IENTER ERRORS ARE:
C  -1: CHANNEL ALREADY OPEN
C  -2: NO SPACE AVAILABLE
C  -3: DEVICE IN USE
C  -4: FILE EXISTS AND IS PROTECTED
C  -5: CASSETTE ONLY
	TYPE *,'IENTER FAILURE TYPE ',IRET
	STOP
C
   90	RETURN
	END
C
	SUBROUTINE FIND(CNAME,EXT,IENTRY)
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)
	INTEGER EXT
	COMMON DIR
C
	DO 44 IENTRY=1,64
	IF (DIR(1,IENTRY) .EQ. "345) GOTO 44	!EMPTY, SKIP
	DO 42 ICHAR=2,12
	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. EXT) GOTO 90	!FOUND IT
C
   44	C O N T I N U E
C  FALL THROUGH MEANS NO MATCH FOUND
	IENTRY=-1
   90	RETURN
	END
C
	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
C
	IDBLK=0	!DISK BLOCK TO WRITE
	IEXT=0	!FIRST EXTENT
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
   10	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)
	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
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	DO 65 INDEX=1,1024
	IF (DBUFF(INDEX) .EQ. 26) GOTO 75
   65	C O N T I N U E
C
   70	IRET=IWRITW(512,DBUFF,IDBLK,IDCHAN)
	IDBLK=IDBLK+2
C  IWRITW RETURNS:
C  -1: EOF
C  -2: HARDWARE ERROR
C  -3: CHANNEL NOT OPEN
C
	IF (IRET .LT. 0) GOTO 95
	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)
	IF (IENTRY .NE. -1) GOTO 8	!NEXT EXTENT
	GOTO 90
C
C  HAVE EOF AT "INDEX"
   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	IF (MODE .EQ. 'A') GOTO 62
	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	IRET=IWRITW(256,DBUFF,IDBLK,IDCHAN)
	IDBLK=1
	GOTO 86
C
   84	IRET=IWRITW(512,DBUFF,IDBLK,IDCHAN)
	IDBLK=2
   86	IF (IRET .LT. 0) GOTO 95
   90	IF (IDBLK .EQ. 0) GOTO 94
	CALL ICLOSE(IDCHAN)
   92	CALL IFREEC(IDCHAN)
	RETURN
C
C  FILE OF 0 LENGTH, EAT IT.
   94	CALL PURGE(IDCHAN)
	GOTO 92
C
   95	TYPE *,'WRITE ERROR IN CPYFIL, TYPE ',IRET
	STOP
	END
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)
	COMMON DIR
C
	CALL GETDIR(ICHAN)
	CALL FIND(CNAME,0,IENTRY)
	IF (IENTRY .EQ. -1) GOTO 50	!UNSUCCESSFUL
	IEXT=0
   10	DIR (1,IENTRY)="345		!SET EMPTY
	IEXT=IEXT+1
	CALL FIND(CNAME,IEXT,IENTRY)	!MORE EXTENTS?
	IF (IENTRY .NE. -1) GOTO 10	!YES
	ISTAT=0
	RETURN
C
   50	ISTAT=-1	!UNSUCCESSFUL
	RETURN
	END