.OPEN CPMALL.FTN
.ENABLE DATA
C V1A Edit #33 3-Aug-84 Autor: -tf-  File: CPDIR.FTN 
C
C	C P D I R . F O R  :  DIRECTORY OPERATIONS FOR CP/M - SD FLOPPIES
C
C	CP/M CONVENTION : 1 BLOCK = 8 RECORDS = 1024 BYTES (~ 1 KBYTE)
C			  1 RECORD = 128 BYTES ( = 1 FLOPPY SECTOR,S.D.)
C
C	H.P. STOEHREL 
C
C	*** V1 ***    1-DEC-81
C	*** V2 ***    4-DEC-81 : SUBROUTINE,USES CPRD
C	*** V3 ***    8-DEC-81 : READS FULL DIRECT.,ENTERS & DELETES FILE
C	*** V4 ***   12-DEC-81 : "EXTENT"-HANDLING
C	*** V5 ***   17-DEC-81 : ENTER FILES
C	*** V6 ***   22-DEC-81 : CORRECT.
C	*** V7 ***   26-MAR-82 : CORRECT.
C	*** V8 ***    1-APR-82 : CORRECT.
C	*** V9 ***    2-APR-82 : CORRECT.
C	*** V10 ***   7-APR-82 : CORRECT.
C	*** V11 ***  25-JUL-84 : CORRECT. (SEMPERT, KUSTER)
C
	SUBROUTINE CPDIR (IFUNC,NAME,IRNO,IDIR,IBLK,ISLO,IFCB)
C
C	IFUNC	: FUNCTION OF CPDIR
C		 = 1 : LIST DIRECTORY
C		 = 2 : FIND FILNAME AND RETURN BLK.NOS.
C			FILENAME IN "NAME",ALL PERTINENT BLK. NOS.
C			RETURNED IN "IBLK"
C		 = 3 : FIND FREE ENTRY AND RETURN BLK.NOS.
C			DIRECTORY INDEX IS MAINTAINED IN "INDX"
C		 = 4 : ENTER NEW FILE AND USED BLK.NOS.
C		 = 5 : DELETE FILE
C		 = 6 : ZERO DIRECTORY
C
C	NAME	: FILENAME TO BE SEARCHED FOR
C		  (MUST BE DIMENSIONED IN CALLING PROG. TO 11)
C	IRNO	: NO. OF BLOCKS OF FILE (= -1 IF FILE NOT FOUND)
C	IBLK	: BLOCK  NOS. OF FILE
C		  (MUST BE DIMENSIONED IN CALLING PROG. TO 256)
C	ISLO	: ARRAY, CONTAINS EMPTY FILE CONTROL BLOCKS (FCB-SLOTS)
C		   (MUST BE DIMENSIONED IN CALLING PROG. TO 256)
C	IFCB	: CURRENT FILE CONTROL BLOCK AS SETUP BY CPWOUT
C
C	THE CP/M DIRECTORY IS CONTAINED IN BLOCKS  0 & 1
C
C---------------------------------------------------------------------
C
	INTEGER*2 IDIR(2),NAME(2),IBLK(2),NARQ(11),IDAT(5),ISLO(2),
	1IFCB(2)
C	
	BYTE IAX
	BYTE DUMMY
C
	DATA IDAT/5*0/			! INITIALIZE DATE ARRAY
C
	IDENS=0
C
	IF (IFUNC.EQ.4) GOTO 10		! THE ONLY EXCEPTION
C
	CALL CPRD (IDIR(1),0)		! READ DIRECTORY BLK. 0
	CALL CPRD (IDIR(1025),1)	! READ DIRECTORY BLK. 1
C
10	GOTO (1000,2000,3000,4000,5000,6000),IFUNC
C
C---------------------------------------------------------------------
C
C	LIST DIRECTORY
C
1000	CONTINUE
1080	CALL DATE (IDAT)
	WRITE(1,1095)IDAT
1095	FORMAT(/' CP/M Directory',10X,'DATE : '5A2//
	1' RECS BYTES EX   FILENAME.TYP'/)
C
	NZF=0
	KBALL=0
C
	DO 1100 K=1,64
	J=(K-1)*32+1
	IF((IDIR(J).EQ."345).OR.(IDIR(J+15).EQ.0)) GOTO 1100
C
	NZF=NZF+1
	KB=IDIR(J+15)/8				! 8 RECORDS = 1KB
	NREC=IDIR(J+15)
	IF(NREC.GT.(KB*8)) KB=KB+1
	KBALL=KBALL+KB	
	IEX=IDIR(J+12)+1
C
	IF (IDIR(J+31).EQ.0) GOTO 1300	! IF LAST BLK# OF FCB=0 > NO EXTENT
C
C>>>>>>
C	TYPE 1197,J
C1197	FORMAT(' CPDIR INDX='I5)
C>>>>>>
	DO 1220 N=1,11
C
C>>>>>>
C	TYPE 1199,NAME(N),NAME(N),IDIR(J+N),IDIR(J+N)
C1199	FORMAT(2(O8,2X,A1))
C>>>>>>
C
1220	NAME(N)=IDIR(J+N)			! FILENAME TO BE SEARCHED FOR
C
	K2A=K+1
	DO 1200 K2=K2A,64			! SEARCH REST OF DIRECTORY
	CALL CPLK (K2,IDIR,NAME,IRNUM)		! FOR THAT FILE.
	IF (IRNUM.EQ.-1) GOTO 1200
C
C>>>>>>
C	TYPE 999,K2A,K2
C999	FORMAT(2I8)
C>>>>>>
C
	J2=(K2-1)*32+1
	NREC=NREC+IDIR(J2+15)
	IEX=IDIR(J2+12)+1		
	KB2=IDIR(J2+15)/8
	IF (IDIR(J2+15).GT.KB2*8) KB2=KB2+1
	KB=KB+KB2
	KBALL=KBALL+KB2
	IDIR(J2)="345			! NEVER WRITE THIS DIRECTORY BACK !!
	IF (IDIR(J2+31).EQ.0) GOTO 1300		! ANY MORE EXTENTS ?
1200	CONTINUE
C
1300	WRITE (1,1111) NREC,KB,IEX,(IDIR(L),L=J+1,J+11)
1111	FORMAT (X,I4,I5,'K',I3,3X,8A1,'.',3A1,20I3)
C
C>>>>>>>
C	WRITE (1,1113) (IDIR(J+M+15),M=1,16)	! WRITE USED BLK.NOS.
C1113	FORMAT(16I4,/)
C>>>>>>>
C
1100	CONTINUE
C
	KBR=241-KBALL				! TOTALLY AVAILABLE ARE 241KB
	WRITE(1,1119)NZF,KBALL,KBR
1119	FORMAT(/
	1I4,' Files using ',I4,' KBytes - ',I4,' KBytes available'/)
	RETURN
C
C---------------------------------------------------------------------
C
C
2000	DO 2004 J=1,256
2004	IBLK(J)=0
C
	IFND=0
	IRNO=0
C
	DO 2002 ISL=1,64
	CALL CPLK(ISL,IDIR,NAME,IRNUM)
	IF(IRNUM.LT.0) GOTO 2002
C
	IFND=1				! REQUESTED FILE FOUND
	K=(ISL-1)*32
	IRNO=IRNO+IDIR(K+16)
	DO 2220 N=1,16
	L=K+N+16
	M=IDIR(L)
	IBLK(M)=M
C
C>>>>>>
C	TYPE 1221,IBLK(M)
C1221	FORMAT(' BLOCK# ',I5)
C>>>>>>
C
2220	CONTINUE
C
2002	CONTINUE
C
	IF (IFND.NE.0) RETURN
C
	TYPE 2109,(NAME(N),N=1,11)
2109	FORMAT(/' ?CPMRSX-W-CP/M File ',8A1,'.',3A1,'  not found'/)
	IRNO=-1
	RETURN
C
C---------------------------------------------------------------------
C
C	FIND FREE ENTRY (SLOT) AND RETURN BLK.NOS.
C
C	FIRST, CHECK WHETHER FILE ALREADY EXISTS
C
3000	IRNO=0					!INITIALIZE IRNO !!
	DO 3004 ISL=1,64
	CALL CPLK (ISL,IDIR,NAME,IRNUM)		! LOOKUP FILE
	IF(IRNUM.EQ.-1) GOTO 3004		! IRNUM=-1  : FILE NOT FOUND
	TYPE 3007,(NAME(N),N=1,11)
3007	FORMAT(/' ?CPMRSX-W-CP/M File ',8A1,'.',3A1,'  allready exists'/)
	IRNO=-1				! FLAG EXISTENCE
	RETURN
C
3004	CONTINUE
C
C	NO SUCH FILE
C
3008	DO 3002 J=1,256
3002	IBLK(J)=0
	DO 3010 J=1,64
3010	ISLO(J)=0
C
C	COLLECT ALL BLOCK NOS.
C
3100	NZR=0			! USED SECTOR COUNT
	IFBS=0
C
	DO 3200 J=1,64
	K=(J-1)*32+1		! IDIR(K+15)=FCB(16)=NO.OF BLOCKS USED BY FILE
C
C>>>>>>
D	TYPE 3902,J,IDIR(K),IDIR(K+12),IDIR(K+15)
D3902	FORMAT(' SLOT#',I3,' FCB(1)=',I3,' FCB(13)=',I3,' FCB(16)=',I3)
C>>>>>>
	NRCT=IDIR(K+15)
	IF (NRCT.EQ.0.OR.NRCT.EQ."345) GOTO 3200	
	NZR=NZR+NRCT			! COUNT USED SECTORS
C
	ISLO(J)=J			! MARK USED SLOTS
C
	DO 3110 N=1,16			! SLOT IN USE - COLLECT BLOCK#
	M=IDIR(K+N+15)
	IBLK(M)=M
C>>>>>
D	TYPE 3099,J,N,M
D3099	FORMAT(' CPDIR- J N M ',3I8)
C>>>>>
	IF (M.EQ.0) IFBS=1		! FLAG "AT LEAST 1 EMPTY BLOCK"
3110	CONTINUE
3200	CONTINUE
C
	DO 3300 J=1,64			! LOOK FOR EMPTY SLOTS
C>>>>>
D	TYPE 3301,J,ISLO(J)
D3301	FORMAT(2I6)
C>>>>>
	IF (ISLO(J).EQ.0) GOTO 3400
3300	CONTINUE
	GOTO 3900			! NO SLOT - ERROR
C
3400	NZR=0				! LOOK FOR EMPTY BLOCKS
	DO 3500 J=2,242
	IF (IBLK(J).EQ.0) NZR=NZR+1
3500	CONTINUE
	IF (NZR.EQ.0) GOTO 3800		! JUST ONE BLOCK LEFT ?
C
C>>>>>>>
D	TYPE 3595
D3595	FORMAT(/' USED SLOTS :'/)
D	TYPE 3597,(ISLO(J),J=1,64)		! TYPE ALL SLOT-#
D	TYPE 3593
D3593	FORMAT(/' USED BLOCKS :'/)
D	TYPE 3597,(IBLK(J),J=1,256)		! TYPE ALL BLOCK-#
D3597	FORMAT(X,20I3)
C>>>>>>>
C
	RETURN
C
3800	TYPE 3021
3021	FORMAT(/' ?CPMRSX-W-No room on volume - all records used'/)
	IRNO=-1
3600	RETURN
C
3900	TYPE 3901
3901	FORMAT(/' ?CPMRSX-W-No room on volume - 64 File Entries'/)
	IRNO=-1
	RETURN
C
C---------------------------------------------------------------------
C
C	WRITE DIRECTORY BACK
C
4000	CONTINUE
C>>>>>>
C	TYPE 4597,(IDIR(J),J=1,1024)		! TYPE ALL DIR.SLOTS
C4597	FORMAT(X,16O4)
C>>>>>>>

	CALL CPWR (IDIR(1),0)		! WRITE DIRECTORY BLK. 0
	CALL CPWR (IDIR(1025),1)	! WRITE DIRECTORY BLK. 1
C
	RETURN
C
C---------------------------------------------------------------------
C
C	DELETE FILE
C
5000	IDEXT=0					! THINK ON FILE EXTENTS
C
5020	DO 5002 ISL=1,64
	CALL CPLK(ISL,IDIR,NAME,IRNUM)		! LOOKUP FILE
	IF(IRNUM.GE.0) GOTO 5100
5002	CONTINUE
C
	IF (IDEXT.EQ.1) GOTO 4000		! WRITE DIRECTORY BACK
C
	TYPE 2109,(NAME(N),N=1,11)
	RETURN
C
5100	KXI=32*(ISL-1)
C
C	A DIRECTORY ENTRY IS CONSIDERED EMPTY IF FCB(16)=0 (RECORD COUNTER).
C	IN ADDITION, WE SET FCB(1)="345 (=e)
C
	IDIR(KXI+1)="345
	IDIR(KXI+16)=0
	IDEXT=1
	GOTO 5020			! TRY ONCE AGAIN
C
C---------------------------------------------------------------------
C
C	ZERO DIRECTORY
C
C	THE DIRECTORY IS FILLED WITH "345 (=e), SO ITS LOOKS LIKE
C	NEWLY FORMATTED .
C
6000	TYPE 6001
6001	FORMAT(/'$?CPMRSX-I-Zero CP/M Directory: are you sure (Y/N) ? ')
	ACCEPT 6003,IAX
6003	FORMAT(A1)
	IF(IAX.NE.'Y') GOTO 6600
C
	DO 6002 J=1,2048
6002	IDIR(J)="345
C
	GOTO 4000		! WRITE DIRECTORY BACK
C
6600	RETURN
C
	END

C V1A Edit #4 3-Jun-83 Autor: -tf-  File: CPFCB.FTN 
C
C	C P F C B . F O R
C
C	H.P. STOEHREL
C
C	*** V1 ***	17-DEC-81
C	*** V2 ***	22-DEC-81
C
C	SUBROUTINE SETS UP NEW FCB AND LOOKS FOR AN EMPTY SLOT IN THE
C	DIRECTORY
C
	SUBROUTINE CPFCB (IFCB,ISLO,NAME,INDX,IERF)
C
	INTEGER*2 ISLO(2),IFCB(2),NAME(2)
C
	IERF=0
C
	DO 10 J=1,32			! INITIALIZE FCB
10	IFCB(J)=0
C
	DO 14 J=1,11
C>>>>>
C	TYPE 99,NAME(J)
C99	FORMAT(X,A1)
C>>>>>
14	IFCB(J+1)=NAME(J)		! ENTER FILENAME
C
	DO 16 J=1,64			! LOOK FOR EMPTY FCB SLOTS
	IF (ISLO(J).EQ.0) GOTO 18
16	CONTINUE
	IERF=1				! ERROR
	GOTO 90
C
18	INDX=(J-1)*32			! CALCULATE ENTRY INDEX
	ISLO(J)=J			! MARK SLOT AS USED
C
90	RETURN
	END

C V1A Edit #16 3-Jun-83 Autor: -tf-  File: CPFI.FTN 
C
C	C P F I . F O R  :  INPUT CP/M FILE NAME
C
C	H.P. STOEHREL 
C
C	*** V1 ***   9-DEC-81
C
	SUBROUTINE CPFI (NAME)
C
	INTEGER*2 NAME(2),IFIL(12)
C
2000	TYPE 2113
2113	FORMAT(' CP/M Filename (abcdefgh.ext) : '$)
	ACCEPT 2119,IANZCH,(IFIL(K),K=1,12)
2119	FORMAT(Q,12A1)
	IF (IANZCH.EQ.0) GOTO 2000
	IF (IANZCH.GT.12) IANZCH = 12
	DO 2010 I=1,IANZCH
2010	IF ((IFIL(I).AND."377).NE."40
     -  .AND.(IFIL(I).AND."377).NE."56) GOTO 2100
	GOTO 2000
2100	DO 2110 I=1,IANZCH
2110	IF ((IFIL(I).AND."377).EQ."52
     -  .OR.(IFIL(I).AND."377).EQ."77) GOTO 2000

	IF((IFIL(I).EQ.'*').OR.(IFIL(I).EQ.'?'))
     -  GOTO 2000
C
	DO 100 I=1,IANZCH
100	IF ((IFIL(I).AND."377).GE."140) IFIL(I)=IFIL(I).AND."177737
C
	DO 2410 L=1,11
2410	NAME(L)="40		! INSERT SPACES
C
2200	K=1
	L=1
2300	IF( IFIL(K).NE."20056) GOTO 2308
	L=9
	GOTO 2320
C
2308	NAME(L)=IFIL(K)-"20000
	L=L+1
2320	K=K+1
	IF (L.LE.11) GOTO 2300
C
	IF (NAME(1).EQ."40) GOTO 2000	! Do not accept extension only!
C
	RETURN
C
	END

C V1A Edit #6 17-Sep-84 Autor: -tf-  File: CPLK.FTN 
C
C	C P L K . F O R  :  LOOKUP FILE IN CP/M DIRECTORY
C
C	H.P. STOEHREL 
C
C	*** V1 ***    9-DEC-81
C	*** V2 ***   12-DEC-81
C	*** V3 ***    7-APR-82 : DON'T CATCH DELETED FILES
C
	SUBROUTINE CPLK (ISL,IDIR,NAME,IRNUM)
C
C	ISL	: SLOT.NO. OF FCB TO BE LOOKED AT
C	NAME	: FILENAME TO BE SEARCHED FOR
C		  (MUST BE DIMENSIONED IN CALLING PROG. TO 11)
C	IRNUM	: NO. OF BLOCKS OF FILE (= -1 IF FILE NOT FOUND)
C
C
	INTEGER*2 IDIR(2),NAME(2)
C
	J=ISL
	K=(J-1)*32+2
C
C>>>>>>
C	TYPE 1023,(IDIR(N),N=K,K+11)
C1023	FORMAT(' CPLK: ',11A1)
C>>>>>>
C
C	LOOK FOR REQUESTED FILENAME & EXT.
C
	DO 1300 M=1,11
C
	IDX=M+K-1
C>>>>>>
C	TYPE 1025,IDX,IDIR(IDX),NAME(M)
C1025	FORMAT (I4,2O8,/)
C>>>>>>
C
C	'FLAG-BIT' AUSMASKIEREN
	IF((IDIR(M+K-1).AND."177577).NE.NAME(M)) GOTO 1020
1300	CONTINUE
C
C	DON'T FIND DELETED FILES !!
C
	IF (IDIR(K+14).EQ.0.OR.IDIR(K-1).EQ."345) GOTO 1020
C
	IRNUM=IDIR(K+14)
	RETURN
C
C
1020	IRNUM=-1
	RETURN
C
C
	END

C V1A Edit #58 6-Jun-83 Autor: -tf-  File: CPMRSX.FTN 
C
C	C P M R T . F O R  :  TRANSFER CP/M - SD FLOPPIES TO RT-11
C	C P M RSX . F O R  :  TRANSFER CP/M - SD FLOPPIES TO RSX
C
C
C	H.P. STOEHREL 
C
C	*** V1 ***    3-DEC-81 : ONLY OUTPUT OF SINGLE RECORDS
C	*** V2 ***    4-DEC-81 : ADDED DIRECTORY LISTING
C	*** V3 ***    8-DEC-81 : PACKED ASCII 2 CHARS/WRD.
C	*** V4 ***    9-DEC-81 : DELETE FILE/ZERO DIRECT.
C	*** V5 ***   12-DEC-81 : EXTENT HANDLING
C	*** V6 ***   17-DEC-81 : WRITE FUNCTION
C	*** V7 ***   22-DEC-81 : CORR.
C	*** V8 ***    3-MAR-82 : CORR. FUNC. 3
C	*** V9 ***   26-MAR-82 : SHIFT-FUNC.
C	*** V10 ***   1-APR-82 : PUTSTRING
C	*** V11 ***   2-APR-82 : CORR.
C	*** V12 ***   6-APR-82 : CORR.
C	*** V13 ***  26-JUL-84 : CORR.
C	***********   5-DEC-85 : ADAPTED TO RSX-11M (M.DUENKI)
C
C
C	File-IO  LUN 1
C	TT:-IO   LUN 5
C
	PROGRAM CPMRSX
C
	INTEGER*2 IT(2),IB(1025),NAME(12),IBLK(257),IOB(513)
	INTEGER*2 IBI(151),ISLO(65),IDIR(2049),IFCB(33),ICHAN,IDRIVE
	INTEGER*2 CPMNAM(12),ISTAT(2)
	BYTE ISTATB(2)
	LOGICAL*1 IBLOG(2050),IBLI(128)
	EQUIVALENCE (IB(1),IBLOG(1)),(ISTAT(1),ISTATB(1))
	CHARACTER*80 INFILE
C
C	INTEGER*4 SYS$ASSIGN
C
	LOGICAL*1 ICH,PUERR,IBO(151),NOTHNG,OPENFL
C
	COMMON /DY/ICHAN,IDRIVE
C
	DATA ICHAN/2/
C
2	TYPE 11
11	FORMAT(/
	1' -------------------------------------------'/
	2' C P M R S X . V 1  -   CP/M to RSX Transfer'/
	3' -------------------------------------------'/)
C
3	TYPE 13
13	FORMAT(/'$CP/M Single density Floppy is in Drive number: ')
	ACCEPT	1,IAN
	IF ((IAN.NE.0) .AND. (IAN.NE.1)) GOTO 3
	IDRIVE=IAN
C	IF (IAN.EQ.0) ISTATU=SYS$ASSIGN('_DYA0:',ICHAN,,)
C	IF (IAN.EQ.1) ISTATU=SYS$ASSIGN('_DYA1:',ICHAN,,)
	CALL ASNLUN(ICHAN,'DY',IAN,ISTAT)		!FOR RSX-11M
C	IF (.NOT.ISTATU)
	IF (ISTATB(1).NE.1)
	1 STOP '?CPMRSX-F-ASSIGN Error (ev. allocated by other user ?'
C
100	CONTINUE	! MAIN LOOP
	CLOSE (UNIT=1)				! JUST IN CASE .....
C
	TYPE 101
101	FORMAT(/
	1' CPMRSX-Commands:'/
	2' 0 = List Directory'/
	3' 1 = Transfer File from CP/M to RSX'/
	4' 2 = Transfer File from RSX to CP/M'/
	5' 3 = Delete CP/M File'/
	6' 4 = Zero CP/M Directory'/
	7' 5 = Exit'/
	8/' CPMRSX Command: '$)
	ACCEPT	1,IAN
1	FORMAT(I7)
	IF (IAN.GT.5.OR.IAN.LT.0) GOTO 100
	IAN=IAN+1
	GOTO (1000,2000,3000,4000,5000,99999),IAN
C
C------------------------------------------------------------------
C
1000	CALL CPRSXN (INFILE, 'CPMDSK  DIR')
	OPEN (UNIT=1,FILE=INFILE,STATUS='NEW',
	1 FORM='FORMATTED',CARRIAGECONTROL='LIST')
C
	CALL CPDIR (1,NAME,IRNUM,IDIR,IBLK,ISLO,IFCB)
C
	IF (INFILE.NE.'TT:') GOTO 1199
	TYPE 16
16	FORMAT('$press RETURN to continue ')
	ACCEPT 17,DUMMY
17	FORMAT(A1)
1199	CLOSE (UNIT=1)
	GOTO 100
C
C------------------------------------------------------------------
C
C	READ FROM CP/M FLOPPY
C
2000	CALL CPFI(NAME)			! INPUT CP/M FILENAME
C
	DO 2010 I = 1,12
2010	CPMNAM(I) = NAME(I)
	CALL CPRSXN(INFILE,CPMNAM)
	TYPE 2011
2011	FORMAT(/' Copy-Modes:',/,
	1       ' 0 = ASCII',/,
	2       ' 1 = Binary',//,
	3       ' Copy-Mode: '$)
	ACCEPT 1,IMOD
	IF((IMOD.GT.1).OR.(IMOD.LT.0)) GOTO 100
	IF(IMOD.GT.0) GOTO 2900
C
	OPEN (UNIT=1,FILE=INFILE,STATUS='NEW',
	1 FORM='FORMATTED',CARRIAGECONTROL='LIST')
	TYPE 21501
21501	FORMAT(/)
C
2200	CALL CPDIR (2,NAME,IRNUM,IDIR,IBLK,ISLO,IFCB)
C
	IF(IRNUM.EQ.-1) GOTO 100
C
C>>>>>>>
C	TYPE 2501,IRNUM,(IBLK(L),L=1,256)
C2501	FORMAT(I7,/,18I4)
C>>>>>>>
C
2600	DO 2604 M=1,150
2604	IBO(M)=0
	L=0
C
	DO 2400 NR=1,256
	IF(IBLK(NR).EQ.0) GOTO 2400
	CALL CPRD(IB,NR)
C
	DO 2550 J=1,1024
C
	ICH=IB(J).AND."177			! FORM 7-BIT ASCII
	IF (ICH.EQ."15) GOTO 2700		! CARRIAGE RETURN
	IF (ICH.EQ."32) GOTO 2800		! 32(CTR/Z) = EOF IN CP/M
	IF (ICH.EQ."10.OR.ICH.EQ."11.OR.
	1   ICH.EQ."14) GOTO 2680	! LEAVE BACKSPACE,TAB & FORM FEED
	IF (ICH.LT."40) GOTO 2550		! REMOVE OTHER CONTROL CHARS
C
2680	L=L+1
	IBO(L)=ICH
	GOTO 2550
C
2700	CONTINUE
	WRITE(1,27001) (IBO(IJK),IJK=1,L)
27001	FORMAT(8(128A1))
C
2588	DO 2560 M=1,150
2560	IBO(M)=0
	L=0
C
2550	CONTINUE
C
2400	CONTINUE
C
2800	CLOSE (UNIT=1)
	GOTO 100
2900	CONTINUE
	OPEN (UNIT=1,FILE=INFILE,STATUS='NEW',
	1 ACCESS='DIRECT',RECL=32,ERR=2990)
	TYPE 21501
C
	CALL CPDIR (2,NAME,IRNUM,IDIR,IBLK,ISLO,IFCB)
C
	IF(IRNUM.EQ.-1) GOTO 100
C
C>>>>>>>
C	TYPE 2501,IRNUM,(IBLK(L),L=1,256)
C>>>>>>>
C
	L=0
	DO 2950 NR=1,256
	IF(IBLK(NR).EQ.0) GOTO 2950
	CALL CPRD(IB,NR)
	J=1
C
2920	CONTINUE
	IF(L.GE.IRNUM) GOTO 2970
	L=L+1
	WRITE(1,REC=L) (IBLOG(IJK),IJK=J,(J+255),2)
	J=J+256
	IF(J.LT.2048) GOTO 2920
C
2950	CONTINUE
C
2970	CLOSE (UNIT=1)
	GOTO 100
C
2990	TYPE 2991
2991	FORMAT(/' ?CPMRSX-W-RSX Output File Open error')
	GOTO 2000
C
C------------------------------------------------------------------
C
C	WRITE TO CP/M FLOPPY
C
3000	OPENFL=.FALSE.
	IFCTL=0				! FIRST TIME WRITE
	NOTHNG=.TRUE.
	IBPOS=1024			! NORMAL END POSITION IN BUFFER
	CALL CPRSXN (INFILE, '           ')
C
	CALL CPFI(NAME)			! INPUT CP/M FILENAME
	TYPE 2011
	ACCEPT 1,IMOD
	IF((IMOD.GT.1).OR.(IMOD.LT.0)) GOTO 100
	IF(IMOD.GT.0) GOTO 3500
C
	OPEN (UNIT=1,FILE=INFILE,STATUS='OLD',ERR=3989,
	1 FORM='FORMATTED',CARRIAGECONTROL='LIST')
C
	CALL CPDIR (3,NAME,IRNUM,IDIR,IBLK,ISLO,IFCB)
	IF (IRNUM.EQ.-1) GOTO 100	! FILE ALREADY EXISTS
C
C	PAUSE 'CPMRSX - PRIOR TO READ'
	IEND=0
C
	K=0
	DO 3106 J=1,150
3106	IBI(J)=0
C
3100	READ(1,3011,END=3116,ERR=3990)JEN,(IBI(L),L=1,150)  ! READ ONE LINE
3011	FORMAT(Q,150A1)
C	JEN=JEN-1
	NOTHNG=.FALSE.
C
C>>>>>>
C	TYPE 3097,(IBI(L),L=1,JEN)
C3097	FORMAT(X,150A1)
C>>>>>>
C
	DO 3170 J=1,JEN
C
	IF(K.LT.1024) GOTO 3180
C
	CALL CPWOUT(IB,IDIR,IBLK,ISLO,IFCB,
	1 NAME,IFCTL,OPENFL,IERR,IBPOS) ! OUTPUT BUFFER
	IF (IERR.EQ.1) GOTO 100
	IFCTL=1					! AFTER FIRST WRITE
	K=0					! OUTPUT CHAR COUNTER
C
3180	K=K+1
	IB(K)=IBI(J)-"20000		! REMOVE SPACE (A2-FORMAT !)
C
C>>>>>>
C	TYPE 3099,K,IB(K),IB(K)
C3099	FORMAT(I5,O8,2X,A1)
C>>>>>>
C
3170	CONTINUE
C
	IF(K.LT.1024) GOTO 3178
	CALL CPWOUT(IB,IDIR,IBLK,ISLO,IFCB,
	1 NAME,IFCTL,OPENFL,IERR,IBPOS) ! OUTPUT BUFFER
	IF (IERR.EQ.1) GOTO 100
	IFCTL=1
	K=0					! OUTPUT CHAR COUNTER
3178	K=K+1
	IB(K)="15				! CR
C>>>>>>
C	TYPE 3099,K,IB(K),IB(K)
C>>>>>>
C
	IF(K.LT.1024) GOTO 3182
	CALL CPWOUT(IB,IDIR,IBLK,ISLO,IFCB,
	1 NAME,IFCTL,OPENFL,IERR,IBPOS) ! OUTPUT BUFFER
	IF (IERR.EQ.1) GOTO 100
	IFCTL=1
	K=0					! OUTPUT CHAR COUNTER
3182	K=K+1
	IB(K)="12				! LF
C>>>>>>
C	TYPE 3099,K,IB(K),IB(K)
C>>>>>>
C
	GOTO 3100
C
3116	IF (NOTHNG) GOTO 3990
	IF(K.LT.1024) GOTO 3186
	CALL CPWOUT(IB,IDIR,IBLK,ISLO,IFCB,
	1 NAME,IFCTL,OPENFL,IERR,IBPOS) ! OUTPUT BUFFER
	IF (IERR.EQ.1) GOTO 100
	IFCTL=1
	K=0					! OUTPUT CHAR COUNTER
3186	K=K+1
	IB(K)="32			! INSERT CTRL/Z (EOF FOR CP/M)
C
	DO 3220 M=K+1,1024
3220	IB(M)=0				! PAD BUFFER WITH ZEROS
C
C>>>>>>
C	PAUSE ' CPMRSX : LAST OUT'
C>>>>>>
	IBPOS=K
	CALL CPWOUT(IB,IDIR,IBLK,ISLO,IFCB,
	1 NAME,-1,OPENFL,IERR,IBPOS) ! LAST BUFFER
	IF (IERR.EQ.1) GOTO 100
C
	CLOSE (UNIT=1)
C
	GOTO 100
3500	CONTINUE
	OPEN (UNIT=1,FILE=INFILE,STATUS='OLD',ERR=3989,
	1 ACCESS='DIRECT',RECL=32)
C
	CALL CPDIR (3,NAME,IRNUM,IDIR,IBLK,ISLO,IFCB)
	IF (IRNUM.EQ.-1) GOTO 100	! FILE ALREADY EXISTS
C
C	PAUSE 'CPMRSX - PRIOR TO READ'
	IEND=0
	L=1
	J=1
C
3550	READ(1,REC=L,ERR=3600)IBLI
	NOTHNG=.FALSE.
C
	IF(J.LT.1024) GOTO 3580
	CALL CPWOUT(IB,IDIR,IBLK,ISLO,IFCB,
	1 NAME,IFCTL,OPENFL,IERR,IBPOS) ! OUTPUT BUFFER
	IF (IERR.EQ.1) GOTO 100
	IFCTL=1					! AFTER FIRST WRITE
	J=1
3580    CONTINUE
	DO 3570 M=J,(J+127)
3570	IB(M)=IBLI(M-J+1).AND."377
	L=L+1
	J=J+128
	GOTO 3550
C
3600	IF (NOTHNG) GOTO 3990
	IF((L.LE.1).AND.(J.LE.1)) GOTO 3990
	IF(J.GE.1024) GOTO 3700
	DO 3650 M=J+1,1024
3650	IB(M)=0
3700	CONTINUE
C
C>>>>>>
C	PAUSE ' CPMRSX : LAST OUT'
C>>>>>>
	IBPOS=J-1
	CALL CPWOUT(IB,IDIR,IBLK,ISLO,IFCB,
	1 NAME,-1,OPENFL,IERR,IBPOS) ! LAST BUFFER
	IF (IERR.EQ.1) GOTO 100
C
	CLOSE (UNIT=1)
C
	GOTO 100
C
3989	TYPE *,' ?CPMRSX-W-RSX Input File Open error'
3990	TYPE 3991
3991	FORMAT(/' ?CPMRSX-W-RSX Input File not found')
	GOTO 3000
C
C
C------------------------------------------------------------------
C
C	DELETE FILE
C
4000	CONTINUE
	TYPE *,'Delete CP/M-File'
	CALL CPFI(NAME)			! INPUT CP/M FILENAME
	CALL CPDIR (5,NAME,IRNUM,IDIR,IBLK,ISLO,IFCB)
	GOTO 100
C
C------------------------------------------------------------------
5000	CONTINUE
	CALL CPDIR (6,NAME,IRNUM,IDIR,IBLK,ISLO,IFCB)
	GOTO 100
C
99999	CONTINUE
	END

C V1A Edit #11 3-Aug-84 Autor: -tf-  File: CPRD.FTN 
C
C	C P R D . F O R  :  READ A RECORD FROM CP/M - SD FLOPPIES
C
C
C	H.P. STOEHREL 
C
C	*** V1 ***   3-DEC-81
C
	SUBROUTINE CPRD (IB,IREC)
C
	INTEGER*2 IB(1024),ITYP(13),IFL(256)
	INTEGER*2 ISEC,ITR,IFUNC,IUNIT,IDENS,IERR
C
C	IB MUST BE DIMENSIONED IN CALLING PROGRAM TO 1024 (INTEGERS)
C	IREC IS THE RECORD-# TO BE READ
C
C	CP/M RECORDS CONSIST OF 8 SECTORS @ 128 BYTES = 1024 BYTES
C
C	CP/M RECORDS START FROM TRACK 2 WITH
C	6 SECTOR INTERLEAVING AND SOME SPECIALITIES
C
C	CP/M DIRECORIES ARE CONTAINED IN RECS 0 & 1
C
C	TYPICAL RECORD FIRST SECTOR :
C
	DATA ITYP/1,23,20,16,11,8,4,25,21,18,13,9,6/
C
	IFUNC=0
	IDENS=0
C
	ITR=(IREC*8)/26+2	! CALCULATE TRACK#
C
	ITY=IREC-(IREC/13)*13	! CALCULATE TYPICAL RECORD
	ISEC=ITYP(ITY+1)	! GET START SECTOR 
C
	ISCT=0			! SECTOR COUNTER
C
100	IPT=ISCT*128		! BUFFER POINTER
	ISCT=ISCT+1		! COUNT SECTORS
	IF (ISCT.GT.8) RETURN	! WE'RE READY
C
C	TYPE 999,ITR,ISEC,IPT,IFUNC,IUNIT,IDENS
C999	FORMAT(' TRACK=',I4,' SECT= ',I4,' IPT= ',I8,' IFUNC=',I3,
C	1' IUNIT=',I3,' IDENS=',I3)
C
	CALL SSEC (IFL,ISEC,ITR,IFUNC,IUNIT,IDENS,IERR)
	IF (IERR.NE.0) GOTO 9000
C
C	TYPE 201,(IFL(K),K=1,256)
C201	FORMAT(X,64A1)
C
	DO 500 K=1,128
500	IB(IPT+K)=IFL(K)
C
	IF (ISEC.NE.21) GOTO 110
	ISEC=2
	GOTO 100
110	IF (ISEC.NE.22) GOTO 120
	ISEC=1
	ITR=ITR+1
	GOTO 100
120	ISEC=ISEC+6		! 6 SECTOR INTERLEAVING... IN GENERAL !
	IF (ISEC.LE.26) GOTO 100
	ISEC=ISEC-26
	GOTO 100
C
9000	IF(IERR.EQ."240) GOTO 9002
	TYPE 9001,IERR
9001	FORMAT(/' ?CPMRSX-F-Unknown DY-Error  ',I3,/)
	CALL EXIT
9002	TYPE 9003
9003	FORMAT(/' ?CPMRSX-F-Floppy Density Error - Please change'/)
	CALL EXIT
C
	END

C
C	C P R S X N . F O R
C
C	*** V1 *** 	19-DEC-84
C	**********       5-DEC-85 : ADAPTED TO RSX-11M (M.DUENKI)
C
C	This Subroutine prompts the user to enter a RSX-filespecification
C	(default is 'TI:'). If he enters a device only, the CPM-filename will 
C	be copied if there is one. A leading space is not accepted.
C
	SUBROUTINE CPRSXN (RSXNAM, CPMNAM)
C
C	BYTE CPMNAM(12), INNAME(16), RSXNAM(17), EXT(3), SCRSTR(7), ANTW
	INTEGER*2 CPMNAM(12), EXT(3), SCRSTR(7), ANTW
	CHARACTER*80 RSXNAM
	CHARACTER*1 TMP
C
	RSXNAM= ' '
100	TYPE 1000
1000	FORMAT ('$RSX filespec. (TI:) ........ : ')
	ACCEPT 1010, NCH, RSXNAM
1010	FORMAT (Q,A80)
	IF (NCH.NE.0) GOTO 110
	RSXNAM='TI:'
	GOTO 500
110	IF (RSXNAM(1:1).EQ.' ') GOTO 100
	IF ((RSXNAM(NCH:NCH).NE.':').AND.
	1 (RSXNAM(NCH:NCH).NE.']')) GOTO 500
	IF (CPMNAM(1).EQ.' ') GOTO 100
	I = 1
120	ICHR=CPMNAM(I).AND."377
C	RSXNAM(NCH+I:NCH+I) = CHAR(ICHR)
	ENCODE(1,121,TMP) ICHR
121	FORMAT(A1)
	RSXNAM(NCH+I:NCH+I) = TMP
	I = I+1
	IF ((CPMNAM(I).AND."377).NE."40.AND.(I.NE.9)) GOTO 120
	RSXNAM(NCH+I:NCH+I) = '.'
	I = I+1
	DO 130 J = 9,11
	ICHR=CPMNAM(J).AND."377
130	CONTINUE
C	RSXNAM(NCH+J-9+I:NCH+J-9+I) = CHAR(ICHR)
	ENCODE(1,121,TMP) ICHR
	RSXNAM(NCH+I:NCH+I) = TMP
500	CONTINUE
C>>>>
C	TYPE 5000, RSXNAM
C5000	FORMAT ('$RSXNAM: ', A80)
C>>>>
	RETURN
C
	END

C V1A Edit #7 3-Aug-84 Autor: -tf-  File: CPWOUT.FTN 
C
C	C P W O U T . F O R
C
C	H.P. STOEHREL
C
C	*** V1 ***	17-DEC-81
C	*** V2 ***	21-DEC-81  CORR.
C	*** V3 ***	 5-APR-82  CORR.
C	*** V4 ***	25-JUL-84  CORR.
C
C	SUBROUTINE SETS UP FCB'S AND WRITES A BLOCK OUT
C
	SUBROUTINE CPWOUT (IB,IDIR,IBLK,ISLO,IFCB,NAME,
	1 IFCTL,OPENFL,IERR,IBPOS)
C
C	IFCTL	: FILE CONTROL BLOCK HANDLING
C		  = 0 OPEN FILE (NEW FCB)
C		  = 1 CONTINUE WRITING
C		  =-1 CLOSE FILE
C	OPENFL	: TRUE:  FILE HAS BEEN OPENED
C		  FALSE: FILE NOT YET OPENED
C
C	IBPOS	: POSITION IN BUFFER
C
	INTEGER*2 IB(2),IDIR(2),IBLK(2),ISLO(2),IFCB(2),NAME(2)
	LOGICAL*1 OPENFL
C
	IERR=0					! HOPEFULLY
C
C>>>>>>
C	TYPE 99,IFCTL
C99	FORMAT(/' IFCTL=',I3)
C>>>>>>
C
	IF (IFCTL.NE.0.AND.OPENFL.EQ..TRUE.) GOTO 100
C
C	OPEN NEW FILE : SET UP FCB
C
	IEXT=0					! EXTENT
	NB=0					! BLOCK COUNT
C>>>>>>>
C	PAUSE ' CPFCB : NEW'
C>>>>>>>
	CALL CPFCB (IFCB,ISLO,NAME,INDX,IERF)	! SET UP NEW FCB
	OPENFL=.TRUE.
	IF (IERF.EQ.1) GOTO 90
C
C>>>>>>
C	TYPE 97,INDX
C97	FORMAT(/' INDX=',I3)
C>>>>>>
C
C
100	DO 20 NR=2,242				! LOOK FOR EMPTY BLOCKS
	IF (IBLK(NR).EQ.0) GOTO 30
20	CONTINUE

90	TYPE 91
91	FORMAT (/' ?CPMRSX-W-CP/M Volume full'/)
	IERR=1
	RETURN					! NO MORE BLOCKS - ERROR
C
30	IBLK(NR)=NR				! MARK BLOCK AS USED
C
C>>>>>>>
D	TYPE 991,NR
D991	FORMAT(' WRITING BLOCK#',I4)
C>>>>>>>
C
C>>>>>>>
C	TYPE 899,(IB(LL),LL=1,1024)
C899	FORMAT(X,A1$)
C>>>>>>>
C
	NB=NB+1					! COUNT BLOCKS
	CALL CPWR (IB,NR)			! WRITE BLOCK
	IFCB(NB+16)=NR				! ENTER BLOCK# IN FCB
	IF(IFCTL.LT.0) GOTO 200			! CLOSE FILE ?
	IF (NB.LT.16) GOTO 240			! 16 BLOCKS PER FCB
C
C	MORE THAN 16 BLOCKS :SET UP FOR EXTENT
C	ENTER FCB IN DIRECTORY
C
	IFCB(16)=NB*8				! NOT REALLY NO.OF RECORDS !!
	IFCB(13)=IEXT				! SET EXTENT
	IEXT=IEXT+1				! COUNT EXTENT
C
	DO 70 J=1,32	
	IDIR(INDX+J)=IFCB(J)			! ENTER FCB INTO DIRECTORY
C>>>>>>
C	TYPE 917,J,IDIR(INDX+J),IDIR(INDX+J)
C917	FORMAT(/' ****SETUP EXTENT'/,I5,2X,A1,O8)
C>>>>>>
70	CONTINUE
	NB=0					! RESET BLOCK COUNT
C
	CALL CPFCB (IFCB,ISLO,NAME,INDX,IERF)	! SET UP NEW FCB
	IF (IERF.EQ.1) GOTO 90
	GOTO 240
C
C	ENTER FCB IN DIRECTORY
C
200	CONTINUE
C
C>>>>>>>
C	PAUSE ' CPFCB : CLOSE'
C	TYPE 97,INDX
C>>>>>>
	IFCB(16)=NB*8-(1024-IBPOS)/128		! NO.OF RECORDS !!
	IFCB(13)=IEXT				! SET EXTENT
C
	DO 220 J=1,32	
	IDIR(INDX+J)=IFCB(J)			! ENTER FCB INTO DIRECTORY
C>>>>>>
C	TYPE 919,J,IDIR(INDX+J),IDIR(INDX+J)
C919	FORMAT(/' **** AFTER CLOSE'/,I5,2X,A1,O8)
C>>>>>>
220	CONTINUE
	NB=1					! RESET BLOCK COUNT
C
C>>>>>>
C	TYPE 901,(IDIR(K),K=1,1024)
C901	FORMAT(X,16O4)
C>>>>>>
C
	CALL CPDIR(4,NAME,IRNO,IDIR,IBLK,ISLO,IFCB)
C
240	RETURN
	END

C V1A Edit #9 3-Aug-84 Autor: -tf-  File: CPWR.FTN 
C
C	C P W R . F O R  :  WRITE A RECORD TO CP/M - SD FLOPPIES
C
C
C	H.P. STOEHREL 
C
C	*** V1 ***   9-DEC-81
C
	SUBROUTINE CPWR (IB,IREC)
C
	INTEGER*2 IB(1024),ITYP(13),IFL(256)
	INTEGER*2 ISEC,ITR,IFUNC,IUNIT,IDENS,IERR
C
C	IB MUST BE DIMENSIONED IN CALLING PROGRAM TO 1024 (INTEGERS)
C	IREC IS THE RECORD-# TO BE WRITTEN
C
C	CP/M RECORDS CONSIST OF 8 SECTORS @ 128 BYTES = 1024 BYTES
C
C	CP/M RECORDS START FROM TRACK 2 WITH
C	6 SECTOR INTERLEAVING AND SOME SPECIALITIES
C
C	CP/M DIRECORIES ARE CONTAINED IN RECS 0 & 1
C
C	TYPICAL RECORD FIRST SECTOR :
C
	DATA ITYP/1,23,20,16,11,8,4,25,21,18,13,9,6/
C
	IFUNC=1
	IDENS=0
C
	ITR=(IREC*8)/26+2	! CALCULATE TRACK#
C
	ITY=IREC-(IREC/13)*13	! CALCULATE TYPICAL RECORD
	ISEC=ITYP(ITY+1)	! GET START SECTOR 
C
	ISCT=0			! SECTOR COUNTER
C
100	IPT=ISCT*128		! BUFFER POINTER
	ISCT=ISCT+1		! COUNT SECTORS
	IF (ISCT.GT.8) RETURN	! WE'RE READY
C
C	TYPE 999,ITR,ISEC,IPT,IFUNC,IUNIT,IDENS
C999	FORMAT(' TRACK=',I4,' SECT= ',I4,' IPT= ',I8,' IFUNC=',I3,
C	1' IUNIT=',I3,' IDENS=',I3)
C
	DO 500 K=1,128
500	IFL(K)=IB(IPT+K)
C
	CALL SSEC (IFL,ISEC,ITR,IFUNC,IUNIT,IDENS,IERR)
	IF (IERR.NE.0) GOTO 9000
C
	IF (ISEC.NE.21) GOTO 110
	ISEC=2
	GOTO 100
C
110	IF (ISEC.NE.22) GOTO 120
	ISEC=1
	ITR=ITR+1
	GOTO 100
C
120	ISEC=ISEC+6		! 6 SECTOR INTERLEAVING... IN GENERAL !
	IF (ISEC.LE.26) GOTO 100
	ISEC=ISEC-26
	GOTO 100
C
9000	IF(IERR.EQ."240) GOTO 9002
	TYPE 9001,IERR
9001	FORMAT(/' ?CPMRSX-F-Unknown DY-Error  ',I3,' (ev. write lock)'/)
	CALL EXIT
9002	TYPE 9003
9003	FORMAT(/' ?CPMRSX-F-Floppy Density Error - Please change'/)
	CALL EXIT
C
	END

C V1A Edit #55 6-Jun-83 Autor: -tf-  File: SSEC.FTN 
C
C	S S E C . F O R : READ / WRITE FLOPPY 
C
C	*** SINGLE SECTORS / SINGLE OR DOUBLE DENSITY ***
C
C	***********   5-DEC-85 : ADAPTED TO RSX-11M (M.DUENKI)
C
C	CALLING SEQUENCE :
C
C	CALL SSEC (IBUF,ISEC,ITR,IFUNC,IUNIT,IDENS,IERR)
C	CALL SSEC (IBUF,ISECT,ITRACK,IFUNC,IUNIT,IDENS,IERR)
C
C	IBUF   = BUFFER (ARRAY)
C	ISECT  = SECTOR #
C	ITRACK = TRACK #
C	IFUNC  = FUNCTION : READ=0, WRITE=1
C	IUNIT  = DRIVE # (0/1)
C	IDENS  = DENSITY (0 = SINGLE , 1 = DOUBLE)
C	IERR   = ERROR
C		= 0 OK.
C		= 1 ISEC=0 OR ISEC>26
C		= 2 ITR >76
C		= 3 IDENS NOT 0 OR 1
C		= 4 BAD FUNCTION
C
C	ICHAN  = CHANNEL FROM $ASSIGN
C
	SUBROUTINE SSEC (IBUF,ISECT,ITRACK,IFUNC,IUNIT,IDENS,IERR)
C
	INTEGER*2 IBUF(256),ISECT,ITRACK,IFUNC,ICHAN,IUNIT,IDENS,IERR
C	INTEGER*4 SYS$QIOW,IDISKA
	INTEGER*4 IDISKA
	INTEGER*2 ITWOBY,IDRIVE,IDISK(2),ISTAT(2),IPARAM(6)
	BYTE LOCBUF(256),TWOBYT(2),ISTATB(2)
	EQUIVALENCE (ITWOBY,TWOBYT(1))
	EQUIVALENCE (IDISKA,IDISK(1)),(IDISK(1),IDISKL),(IDISK(2),IDISKH)
	EQUIVALENCE (ISTAT(1),ISTATB(1))
C
	COMMON /DY/ICHAN,IDRIVE
C
	DATA IORPB,IOWPB/O1040,O440/
C
C	INCLUDE '($IODEF)'
C	INCLUDE '($SSDEF)'
C
	IERR=0
C	IDISKA=(ITRACK*65536)+ISECT
	IDISKA=(ITRACK*26)+ISECT-1
	NBYTE=128
	IF (IDENS.EQ.1) NBYTE=256	
C
	IF (IFUNC.EQ.0) GOTO 100
	IF (IFUNC.EQ.1) GOTO 200
	IERR=4
	STOP '?CMPRSX-F-Internal IFUNC Error'
C
100	CONTINUE
C	ISTATU=SYS$QIOW(,%VAL(ICHAN),%VAL(IO$_READPBLK)
C	1,,,,LOCBUF,%VAL(NBYTE),%VAL(IDISKA),,,)
	CALL GETADR(IPARAM(1),LOCBUF(1))
	IPARAM(2)=NBYTE
	IPARAM(4)=IDISKH
	IPARAM(5)=IDISKL
C	IPARAM(5)=IDISKA
	CALL WTQIO(IORPB,ICHAN,1,,ISTAT,IPARAM)		!FOR RSX-11M
C	IF (.NOT.ISTATU) TYPE 101,ISTATU
C101	FORMAT(' ?CPMRSX-W-Read Status',Z,' (hex)')
	IF(ISTATB(1).NE.1) TYPE 101,ISTAT(1)
101	FORMAT(' ?CPMRSX-W-Read Status',O7,' (oct)')
C	IF (ISTATU .EQ. SS_NOPRIV) TYPE 102,IDRIVE
102	FORMAT(' Did you MOUNT/FOREIGN DY',I1,': ?')
C	IF (.NOT.ISTATU) STOP '?CPMRSX-F-Read Error'
	IF (ISTATB(1).NE.1) STOP '?CPMRSX-F-Read Error'
C
	DO 110 I=1,256
110	IBUF(I)=LOCBUF(I) .AND. "377 ! LOW BYTE ONLY
	GOTO 999
C
200	CONTINUE
C	TYPE *,'?CPMRSX-W-Write not yet implemented'
C	GOTO 999
C
	DO 210 I=1,256
	ITWOBY=IBUF(I) .AND. "377 ! LOW BYTE ONLY
	LOCBUF(I)=TWOBYT(1)
210	CONTINUE
C
C	ISTATU=SYS$QIOW(,%VAL(ICHAN),%VAL(IO$_WRITEPBLK)
C	1,,,,LOCBUF,%VAL(NBYTE),%VAL(IDISKA),,,)
	CALL GETADR(IPARAM(1),LOCBUF(1))
	IPARAM(2)=NBYTE
	IPARAM(4)=IDISKH
	IPARAM(5)=IDISKL
C	IPARAM(5)=IDISKA
	CALL WTQIO(IOWPB,ICHAN,1,,ISTAT,IPARAM)		!FOR RSX-11M
C	IF (.NOT.ISTATU) TYPE *,'?CPMRSX-W-Write Status',ISTATU
	IF (ISTATB(1).NE.1) TYPE *,'?CPMRSX-W-Write Status',ISTAT(1)
C	IF (.NOT.ISTATU) STOP '?CPMRSX-F-Write Error'
	IF (ISTATB(1).NE.1) STOP '?CPMRSX-F-Write Error'
	GOTO 999
C
999	RETURN
	END

C V1A Edit #1 30-May-83 Autor: -tf-  File: [TF.KUSTER]CPMBLK.FOR 
C
C	C P M B L K  . F O R  :  TRANSFER CP/M - SD FLOPPIES TO RT-11
C
C
C	H.P. STOEHREL 
C
C	*** V2 ***   26-MAR-82
C
	PROGRAM CPMBLK
C
	BYTE IB(1024),IB2(1024)
C
	ICN1=64
	ICN2=1024
C
2	TYPE 11
11	FORMAT(//' C P M B L K . V 2'/
	1/' READ SINGLE BLOCKS FROM CP/M FLOPPIES'//)
C
	IDV=7
106	TYPE 101
101	FORMAT(/' OUTPUT TO TTY = 7 , LPT = 6  : '$)
	ACCEPT	1,IDV
1	FORMAT(I7)
C
	TYPE 91
91	FORMAT(/' OCTAL = O ; ASCII = A ; BOTH = X : '$)
	ACCEPT	93,ICOD
93	FORMAT(A1)
C
100	TYPE 121
121	FORMAT(///' ------ BLOCK-# : '$)
	ACCEPT 123,IBLK
123	FORMAT(I7)
C
	CALL CPRD (IB,IBLK)
C
C	CLEAN UP FOR ASCII OUTPUT
C	IF "A" - OUTPUT,REPLACES ALL CONTROL CHARS BUT CR,LF AND TAB BY @
C	IF "X" - OUTPUT,REPLACES ALL CONTROL CHARS BY @
C
	DO 70 L=1,1024
70	IB2(L)="100
C
	L=1
80	IC=IB(L).AND."177
	IF(ICOD.EQ.'X') GOTO 86 
	IF(IC.EQ."11) GOTO 82
	IF(IC.EQ."12) GOTO 82
	IF(IC.EQ."15) GOTO 82
86	IF(IC.EQ."177) GOTO 84
	IF(IC.LT."40) GOTO 84
82	IB2(L)=IC
84	L=L+1
	IF(L.LE.ICN2) GOTO 80
C
	IF(ICOD.EQ.'A') GOTO 160
C
	IAD=0
	DO 1000 L=1,ICN1
	K=(L-1)*16+1
	WRITE(IDV,1121)IAD,(IB(J),J=K,K+15)
1121	FORMAT(O6,'/',2X,16O4)
C
140	IF(ICOD.NE.'X') GOTO 1000
	WRITE(IDV,1123)(IB2(J),J=K,K+15)
1123	FORMAT(9X,16(3X,A1))
C
1000	IAD=IAD+16
	GOTO 110
C
C	ASCII ONLY
C
160	WRITE(IDV,163)(IB2(J),J=1,ICN2)
163	FORMAT(X,128A1)
C
110	CONTINUE
C
	CALL CLOSE (IDV)
	GOTO 100
C
	END

C V1A Edit #37 31-May-83 Autor: -tf-  File: [TF.KUSTER]TSSEC.FOR 
C
C	T S S E C . F O R  :  TEST PROGRAM FOR SSEC.FOR (READ/WRITE-FLOPPY)
C
C	READS/WRITES DATA FROM/TO FLOPPY / SINGLE  SECTOR
C
C	H.P. STOEHREL 
C
C	*** V1 ***  4-FEB-80 
C	*** V2 *** 24-NOV-81 ASCII/OCTAL
C	*** V3 *** 26-NOV-81 SINGLE & DOUBLE DENSITY
C	**********  5-DEC-85 : ADAPTED TO RSX-11M (M.DUENKI)
C
	PROGRAM TSSEC
C
	INTEGER*2 ISEC,ITR,IFUNC,IUNIT,IDENS,IERR
	INTEGER*2 IBUF(256),IB2(256),ISTAT(2)
	BYTE ISTATB(1)
	EQUIVALENCE (ISTAT(1),ISTATB(1))
C	INTEGER*4 SYS$ASSIGN
C
	COMMON /DY/ICHAN
C
	DATA ICHAN/2/
C
	IDV=5
	TYPE 11
11	FORMAT(//' T S S E C . V 3/RSX'//)
C***
	IFUNC=0
C
C	ISTATUS=SYS$ASSIGN('_DYA0:',ICHAN,,)
	CALL ASNLUN(ICHAN,'DY',0,ISTAT)			!FOR RSX11M
C	IF (.NOT.ISTATUS) STOP '?CPMRSX-F-ASSIGN Error'
	IF (ISTATB(1).NE.1) STOP '?CPMRSX-F-ASSIGN Error'
C
C	TYPE 21
C21	FORMAT(/' READ= 0 , WRITE = 1 ' $)
C	ACCEPT 1,IFUNC
C***
	IDENS=1
	ICN1=16
	ICN2=256
108	TYPE 109
109	FORMAT(/' FLOPPY DENSITY (SINGLE = S , DOUBLE = D ) : '$)
	ACCEPT	93,IDS
	IF(IDS.EQ.'D') GOTO 106
	IF(IDS.NE.'S') GOTO 108
	IDENS=0
	ICN1=8
	ICN2=128
C
106	CONTINUE
C106	TYPE 101
C101	FORMAT(/' OUTPUT TO TTY = 7 , LPT = 6  : '$)
C	ACCEPT	1,IDV
1	FORMAT(I7)
C
	TYPE 91
91	FORMAT(/' OCTAL = O ; ASCII = A ; BOTH = X : '$)
	ACCEPT	93,ICOD
93	FORMAT(A1)
C
202	TYPE 17
17	FORMAT(/' TRACK-NO. : '$)
	ACCEPT 1,ITR
C
	TYPE 13
13	FORMAT(/' FROM SECTOR-NO. : '$)
	ACCEPT 1,ISECA
C
	TYPE 15
15	FORMAT(/' TO  SECTOR-NO.  : '$)
	ACCEPT 1,ISECF
	IF (IFUNC .EQ. 0) GOTO 100
C
C	*** WRITE ***
C
C	TYPE 9
C9	FORMAT(/' OFFSET : '$)
C	ACCEPT 1,IOF
C	DO 20 J=1,256
C20	IBUF(J)=J+IOF
C2	CALL SSEC (IBUF,ISEC,ITR,IFUNC,IUNIT,IDENS,IERR)
C	GOTO 202
C
C	*** READ ***
C
100	CONTINUE
	DO 110 ISEC=ISECA,ISECF
C
	WRITE (IDV,111)ITR,ISEC
111	FORMAT (/' *** TRACK ',I3,'  SECTOR ',I3,' ***'/)
C
	DO 987 III=32,126
987	IBUF(III)=III
C
	CALL SSEC (IBUF,ISEC,ITR,IFUNC,IUNIT,IDENS,IERR)
	IF (IERR.NE.0) GOTO 9000
C
C	CLEAN UP FOR ASCII OUTPUT
C	IF "A" - OUTPUT,REPLACES ALL CONTROL CHARS BUT CR,LF AND TAB BY @
C	IF "X" - OUTPUT,REPLACES ALL CONTROL CHARS BY @
C
	DO 70 L=1,256
70	IB2(L)="100
	L=1
80	IC=IBUF(L).AND."177
	IF(ICOD.EQ.'X') GOTO 86 
	IF(IC.EQ."11) GOTO 82
	IF(IC.EQ."12) GOTO 82
	IF(IC.EQ."15) GOTO 82
86	IF(IC.EQ."177) GOTO 84
	IF(IC.LT."40) GOTO 84
82	IB2(L)=IC
84	L=L+1
	IF(L.LE.ICN2) GOTO 80
C
	IF(ICOD.EQ.'A') GOTO 160
C
	IAD=0
	DO 1000 L=1,ICN1
	K=(L-1)*16+1
	WRITE(IDV,121)IAD,(IBUF(J),J=K,K+15)
121	FORMAT(O6,'/',2X,16O4)
C
140	IF(ICOD.NE.'X') GOTO 1000
	WRITE(IDV,123)(IB2(J),J=K,K+15)
123	FORMAT(9X,16(3X,A1))
C
1000	IAD=IAD+16
	GOTO 110
C
C	ASCII ONLY
C
160	WRITE(IDV,163)(IB2(J),J=1,ICN2)
163	FORMAT(X,128A1)
C
C
110	CONTINUE
C
	CALL CLOSE (IDV)
	GOTO 202
C
9000	IF (IERR.EQ."240) GOTO 9002
	TYPE 9001,IERR
9001	FORMAT(/' ?ERR ',I3,/)
	CALL EXIT
9002	TYPE 9003
9003	FORMAT (/' *** FLOPPY DENSITY ERROR - PLEASE CHANGE ***'/)
	GOTO 202
C
	END

.DISABLE DATA
.CLOSE
;F4P CPMALL=CPMALL/F77/TR:ALL
F77 CPMALL=CPMALL/F77/TR:ALL
LBR CPMALL/CR=CPMALL
;
.OPEN CPMRSX.CMX
.ENABLE DATA
CPMRSX=CPMALL/LB:CPMRSX,CPMALL/LB
/
MAXBUF=1024
LIBR=FCSRES:RO
//
.DISABLE DATA
.CLOSE
.OPEN TSSEC.CMX
.ENABLE DATA
TSSEC=CPMALL/LB:TSSEC,CPMALL/LB
/
MAXBUF=1024
LIBR=FCSRES:RO
//
.DISABLE DATA
.CLOSE
.OPEN CPMBLK.CMX
.ENABLE DATA
CPMBLK=CPMALL/LB:CPMBLK,CPMALL/LB
/
MAXBUF=1024
LIBR=FCSRES:RO
//
.DISABLE DATA
.CLOSE
TKB @CPMRSX.CMX
.ASK OK Build CPMBLK (ueberfluessig)
.IFT OK TKB @CPMBLK.CMX
.ASK OK Build TSSEC (ueberfluessig)
.IFT OK TKB @TSSEC.CMX
PIP CPMALL.FTN;*,CPMALL.OBJ;*/DE
.ASK OK Delete Taskbuild-Commandfiles and Library
.IFF OK .STOP
PIP CPMRSX.CMX;*,TSSEC.CMX;*,CPMBLK.CMX;*,CPMALL.OLB;*/DE