      PROGRAM CPM
	COMMON/CHANEL/ICHAN
	DIMENSION IBLK(4)
	REAL*4 IDV
	BYTE ANS,YES
	DATA YES/'Y'/
	DATA IBLK/3RDX0,0,0,0/
	DATA IDV/3RLP /
	ILP=0
	IF(IFETCH(IDV).NE.0)ILP=1
	ICHAN=IGETC(ICHAN)
	IF(LOOKUP(ICHAN,IBLK).LT.0)STOP 'BAD LOOKUP'
	TYPE 87
87	FORMAT('0DO YOU HAVE A LINE PRINTER? ',$)
	ACCEPT 88,ANS
88	FORMAT(A1)
	IF(ANS.NE.YES)ILP=1
      PAUSE 'PLACE CP/M DISK IN DRIVE 0, RT11 IN DRIVE 1'
10    TYPE 11
11    FORMAT('0ENTER SELECTION',/,' 1)CP/M DIRECTORY (TT)',/,
     A ' 2)CP/M DIRECTORY (LP)',/,
     1 ' 3)CP/M TO RT11',/,' 4)RT11 TO CP/M',/,
     2 ' 5)DELETE CP/M FILE',/,' 6)INITILIZE CP/M',/,' 7)EXIT',/
     3 '0? ',$)
      ACCEPT 15,ISEL
15    FORMAT(I1)
      IF(ISEL.LE.0.OR.ISEL.GE.7)GO TO 999
      CALL GETDIR
      GO TO (100,150,200,300,400,500)ISEL
200   CALL ASKCPM
      IF(NREAD(0).NE.0)GO TO 9200
      CALL ASKRT(1)
210   IF(IGCPM(0).NE.0)GO TO 290
      CALL RT11W
      GO TO 210
290   CALL CLOSE(1)
      GO TO 10
300   CALL ASKCPM
	IF(NREAD(1).EQ.0)GO TO 9300
      IF(NWRITE(0).NE.0)GO TO 9350
      CALL ASKRT(2)
310   IF(IGRT(0).NE.0)GO TO 390
      CALL CPMW(0) 
      GO TO 310
390   CALL CPMW(1) 
      CALL CLOSE(1)
      GO TO 10
100   CALL DIRECT(0)
      GO TO 10
150	IF(ILN.NE.0)GO TO 100
	CALL DIRECT(1)
      GO TO 10
400	CALL DELETE
	GO TO 10
500	CALL ZERO
	GO TO 10
9200	TYPE 9201
9201	FORMAT(' FILE NOT FOUND')
	GO TO 10
9300	TYPE 9301
9301	FORMAT(' FILE ALREADY EXISTS')
	GO TO 10
9350	TYPE 9351
9351	FORMAT(' DIRECTORY TABLE FULL')
	GO TO 10
999	PAUSE 'REPLACE SYSTEM DISK'
      END
      SUBROUTINE GETDIR
C  GET CPM DIRECTORY
	COMMON/CHANEL/ICHAN
      COMMON/GLUE/OC,NAME,EXT,EXTN,D1,NOS,BLN
      COMMON/PAS/MAP(26)
      COMMON/DIR/TDIR,AVAIL
      BYTE TDIR(32,64),DIR(32),OC,NAME(8),EXT(3),EXTN,D1(2),NOS,BLN(16)
      INTEGER AVAIL(242)
	EQUIVALENCE (DIR,OC)
      DATA MAP/1,7,13,19,25,5,11,17,23,3,9,15,21,
     1         2,8,14,20,26,6,12,18,24,4,10,16,22/
      DATA AVAIL/1,241*0/
	DO 20 I=2,242
20	AVAIL(I)=0
      J=1
      DO 5 I=1,16
6     IF(IREAD(ICHAN,2,MAP(I),TDIR(J,1)).EQ.0)GO TO 5
      PAUSE 'CP/M DIRECTORY READ ERROR'
      GO TO 6
5     J=J+128
      DO 10 IP=1,64
      DO 11 I=1,32 
11    DIR(I)=TDIR(I,IP)
      IF(IBYTE(OC).EQ.229)GO TO 10
      DO 12 I=1,16 
      J=IBYTE(BLN(I))
      IF(J.NE.0)AVAIL(J)=1
12    CONTINUE
10    CONTINUE
      RETURN
      END
      SUBROUTINE ASKCPM
C  ASK FOR CPM FILE NAME AND EXTENSION
C  NOTE ENTER NAME AND EXTENSION SEPERATELY
      COMMON/NAME/NAM,EX,NEXT,IPOS
      BYTE NAM(8),EX(3),NEXT,IPOS
      DO 1 I=1,11
1     NAM(I)=32
      TYPE 2
2     FORMAT('0CP/M FILE NAME: ',$)
      ACCEPT 3,J,(NAM(I),I=1,J)
3     FORMAT(Q,:,8A1)
      TYPE 4
4     FORMAT(' CP/M EXTENSION: ',$)
      ACCEPT 3,J,(EX(I),I=1,J)
      NEXT=0
      RETURN
      END
      SUBROUTINE ASKRT(I)
C  ASK FOR RT11 FILE NAME
C  NOTE ENTER FILE NAME & EXTENSION TOGETHER SEPERATED BY A "." (RT11 FORMAT)
      COMMON/POINT/IZ
      TYPE 1
1     FORMAT('0RT11 FILE NAME AND EXTENSION: ',$)
      GO TO (10,20)I
10    CALL ASSIGN(1,,-1,'NEW')
      GO TO 30
20    CALL ASSIGN(1,,-1,'OLD')
30    DEFINE FILE 1(0,256,U,JZ)
      IZ=0
      RETURN
      END
      FUNCTION NREAD(IJ)
      COMMON/GLUE/OC,NAME,EXTN,D
      COMMON/DIR/TDIR,AVAIL
      COMMON/NAME/NAM,NEXT,IPOS
      COMMON/BLOCK/IBN
      BYTE OC,NAM(11),EXTN,NEXT,D(20),TDIR(32,64),DIR(32),IPOS,NAME(11)
	BYTE N
      INTEGER AVAIL(242)
      EQUIVALENCE (DIR,OC)
      DO 1 IP=1,64 
      DO 2 I=1,32
2     DIR(I)=TDIR(I,IP)
      IF(IBYTE(OC).EQ.229)GO TO 1
      IF(EXTN.NE.NEXT)GO TO 1
      DO 3 I=1,11
	N=NAME(I).AND."177
      IF(N.NE.NAM(I))GO TO 1
3     CONTINUE
      GO TO 10
1	CONTINUE
      NREAD=1
      RETURN
10    IBN=0
	IPOS=IP
      NREAD=0
      RETURN
      END
      FUNCTION IGCPM(IJ)
	COMMON/CHANEL/ICHAN
	COMMON/GLUE/BG,NOS,BLN
      COMMON/BLOCK/IBN
      COMMON/BUF/IBUF
      COMMON/NAME/NAM,NEXT,IPOS
      BYTE BG(15),BLN(16),IBUF(1024),NAM(11),NEXT,IPOS,NOS
1     IBN=IBN+1
      IF(IBN.GT.16)GO TO 100 
      I=IBYTE(BLN(IBN))
      IF(I.EQ.0)GO TO 999
      J=1
      DO 10 L=1,8
9     IF(IREAD(ICHAN,ITRACK(I,L),ISEC(I,L),IBUF(J)).EQ.0)GO TO 10
      PAUSE 'CP/M SECTOR READ ERROR'
      GO TO 9
10    J=J+128
	N=IBYTE(NOS)-8
	NOS=N
	IF(NOS.GE.0)GO TO 90
	N=-N*128
	DO 20 I=1,N
20	IBUF(1025-I)=0
90	CONTINUE
      IGCPM=0
      RETURN
100   NEXT=NEXT+1
      IF(NREAD(1).EQ.0)GO TO 1
999   IGCPM=1
      RETURN
      END
      FUNCTION ITRACK(I,J)
      L=I*8+J-1
      ITRACK=L/26+2
      RETURN
      END
      FUNCTION ISEC(I,J)
      COMMON/PAS/MAP(26)
      L=I*8+J-1
      L=MOD(L,26)+1
      ISEC=MAP(L)
      RETURN
      END
      SUBROUTINE RT11W
      COMMON/BUF/IB1,IB2
      COMMON/POINT/IZ
      BYTE IB1(512),IB2(512) 
      IZ=IZ+1
      WRITE(1'IZ,ERR=10)IB1
      IZ=IZ+1
      WRITE(1'IZ,ERR=10)IB2
      RETURN
C  ERROR COULD BE THAT THERE IS NOT ENOUGH ROOM FOR FILE ON DISK
10    PAUSE 'RT11 WRITE ERROR'
      RETURN
      END
      FUNCTION NWRITE(IJ)
      COMMON/GLUE/OC,NAME,EXTN,D,NOS,BLN
      COMMON/DIR/TDIR,AVAIL
      COMMON/NAME/NAM,NEXT,IPOS
      BYTE TDIR(32,64),DIR(32),OC,NAME(11),NAM(11),EXTN,NEXT,D(2)
      BYTE NOS,BLN(16),IPOS
      INTEGER AVAIL(242)
      EQUIVALENCE (DIR,OC)
      DO 1 IP=1,64 
      DO 2 I=1,32
2     DIR(I)=TDIR(I,IP)
      IF(IBYTE(OC).NE.229)GO TO 1
      GO TO 10
1     CONTINUE
      NWRITE=1
      RETURN
10    IPOS=IP
      OC=0
	D(1)=0
	D(2)=0
      EXTN=NEXT
      DO 11 I=1,11 
11    NAME(I)=NAM(I)
      DO 12 I=1,16 
12    BLN(I)=0
      NOS=0
      NWRITE=0
      RETURN
      END
      FUNCTION IGRT(IJ)
	COMMON/GLUE/BEG,NOS,EN
      COMMON/POINT/IZ
      COMMON/BUF/IB1,IB2
      BYTE IB1(512),IB2(512) 
	BYTE BEG(15),NOS,EN(16)
      IZ=IZ+1
      READ(1'IZ,END=900,ERR=900)IB1
      IZ=IZ+1
      READ(1'IZ,END=100,ERR=100)IB2
      IGRT=0
      RETURN
100   DO 30 I=1,512
30    IB2(I)=26
	NOS=NOS-4
	IGRT=0
	RETURN
900   IGRT=1
      RETURN
      END
      SUBROUTINE CPMW(IJ)
	COMMON/CHANEL/ICHAN
      COMMON/BUF/IBUF
      COMMON/GLUE/OC,NOS,BLN 
      COMMON/DIR/TDIR,AVAIL
      COMMON/NAME/NAM,NEXT,IPOS
      COMMON/PAS/MAP(26)
      BYTE OC(15),NOS,BLN(16),TDIR(32,64),DIR(32),NAM(11),NEXT,IPOS
      BYTE IBUF(1024)
      INTEGER AVAIL(242)
      EQUIVALENCE (DIR,OC)
	I=IJ+1
	GO TO (1,99,100)I
1     NOS=NOS+8
      I=IBYTE(NOS) 
      IF(I.GT.128)GO TO 98
      I=(I+4)/8
      DO 5 N=1,242 
      IF(AVAIL(N).EQ.0)GO TO 10
5     CONTINUE
      PAUSE 'CP/M DIRECTORY TABLE FULL'
      RETURN
10    AVAIL(N)=1
      BLN(I)=N
      J=1
      DO 20 L=1,8
9     IF(IWRITE(ICHAN,ITRACK(N,L),ISEC(N,L),IBUF(J)).EQ.0)GO TO 20
      PAUSE 'CP/M WRITE ERROR'
      GO TO 9
20    J=J+128
      RETURN
98	NOS=128
99    NEXT=NEXT+1
      DO 90 I=1,32 
90    TDIR(I,IPOS)=DIR(I)
100	CONTINUE
      J=1
      DO 95 I=1,16 
91    IF(IWRITE(ICHAN,2,MAP(I),TDIR(J,1)).EQ.0)GO TO 95
      PAUSE 'CP/M DIRECTORY WRITE ERROR'
      GO TO 91
95    J=J+128
      IF(IJ.NE.0)RETURN
      IF(NWRITE(0).EQ.0)GO TO 1
      PAUSE 'CP/M DEVICE FULL'
      RETURN
      END
      FUNCTION IBYTE(J)
      BYTE J
      I=J
      IBYTE=I.AND."377
      RETURN
      END
	SUBROUTINE DIRECT(IM)
	COMMON/GLUE/OC,NAME,EXTN,D1,NOS,BLN
	COMMON/DIR/TDIR,AVAIL
	BYTE OC,NAME(11),EXTN,D1(2),NOS,BLN(16),TDIR(32,64),DIR(32)
	INTEGER AVAIL(242)
	EQUIVALENCE (DIR,OC)
	IBF=242
	DO 10 I=1,242
10	IBF=IBF-AVAIL(I)
	IF(IM.NE.0)PRINT 1
1	FORMAT(1H1)
	DO 100 IP=1,64
	DO 110 I=1,32
110	DIR(I)=TDIR(I,IP)
	JC=IBYTE(OC)
	IF(JC.EQ.229)GO TO 100
	IF(EXTN.EQ.0)TYPE 127,NAME
127	FORMAT(' FILE NAME = ',8A1,'.',3A1)
	IF(IM.EQ.0)GO TO 100
	PRINT 120,NAME
120	FORMAT('0FILE NAME = ',8A1,'.',3A1)
	PRINT 125,IBYTE(NOS),IBYTE(EXTN),(IBYTE(BLN(K)),K=1,16)
125	FORMAT(1X,I4,' SECTORS',/,' EXTENSION NUMBER ',I4,/,
     1  ' BLOCK NUMBERS ',/,1X,15(I3,','),I3)
100	CONTINUE
	TYPE 50,IBF
50	FORMAT('0FREE SPACE = ',I3,'K')
	IF(IM.NE.0)PRINT 50,IBF
	RETURN
	END
	SUBROUTINE DELETE
	COMMON/DIR/TDIR,AVAIL
	COMMON/NAME/NAM,NEXT,IPOS
	BYTE TDIR(32,64),NAM(11),NEXT,IPOS
	INTEGER AVAIL(242)
	CALL ASKCPM
1	IF(NREAD(1).NE.0)GO TO 9
	TDIR(1,IPOS)=229
	NEXT=NEXT+1
	GO TO 1
9	CALL CPMW(2)
	RETURN
	END
	SUBROUTINE ZERO
	COMMON/DIR/TDIR,AVAIL
	BYTE TDIR(2048)
	INTEGER AVAIL(242)
	DO 1 I=1,2048
1	TDIR(I)=229
	CALL CPMW(2)
	RETURN
	END
	FUNCTION IREAD(ICHAN,IT,IS,IB)
	COMMON/SAVE/ID,IBT(64)
	DIMENSION IB(64)
	ID=0
	IREAD=ISPFNW("377,ICHAN,IT,ID,IS)
	DO 1 I=1,64
1	IB(I)=IBT(I)
	RETURN
	END
	FUNCTION IWRITE(ICHAN,IT,IS,IB)
	COMMON/SAVE/ID,ITB(64)
	DIMENSION IB(64)
	ID=0
	DO 1 I=1,64
1	ITB(I)=IB(I)
	IWRITE=ISPFNW("376,ICHAN,IT,ID,IS)
	RETURN
	END
