C V1A Edit #58 6-Jun-83 Autor: -tf- File: [TF.KUSTER]CPMVAX.FOR C C C P M R T . F O R : TRANSFER CP/M - SD FLOPPIES TO RT-11 C C P M VAX . F O R : TRANSFER CP/M - SD FLOPPIES TO VAX 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 C C File-IO LUN 1 C TT:-IO LUN 5 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 CHARACTER*80 FILENAME C INTEGER*4 SYS$ASSIGN C LOGICAL*1 ICH,PUERR,IBO(151),NOTHING,OPENFL C COMMON /DY/ICHAN,IDRIVE C 2 TYPE 11 11 FORMAT(/ 1' -------------------------------------------'/ 2' C P M V A X . V 1 - CP/M to VAX Transfer'/ 3' -------------------------------------------'/) C 3 TYPE 13 13 FORMAT(/'$Die CP/M Single density Floppy ist im Drive Nr.: ') ACCEPT 1,IAN IF ((IAN.NE.0) .AND. (IAN.NE.1)) GOTO 3 IDRIVE=IAN IF (IAN.EQ.0) ISTATUS=SYS$ASSIGN('_DYA0:',ICHAN,,) IF (IAN.EQ.1) ISTATUS=SYS$ASSIGN('_DYA1:',ICHAN,,) IF (.NOT.ISTATUS) 1 STOP '?CPMVAX-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' CPMVAX-Commands:'/ 2' 0 = List Directory'/ 3' 1 = Transfer File from CP/M to VAX'/ 4' 2 = Transfer File from VAX to CP/M'/ 5' 3 = Delete CP/M File'/ 6' 4 = Zero CP/M Directory'/ 7/' CPMVAX Command: '$) ACCEPT 1,IAN 1 FORMAT(I7) IF (IAN.GT.4.OR.IAN.LT.0) GOTO 100 IAN=IAN+1 GOTO (1000,2000,3000,4000,5000),IAN C C------------------------------------------------------------------ C 1000 CALL CPDIR (1,NAME,IRNUM,IDIR,IBLK,ISLO,IFCB) GOTO 100 C C------------------------------------------------------------------ C C READ FROM CP/M FLOPPY C 2000 CALL CPFI(NAME) ! INPUT CP/M FILENAME C 2100 TYPE 2129 2129 FORMAT('$VAX Output Filename: (TT:) ') ACCEPT 15,IANZCH,FILENAME 15 FORMAT(Q,A80) IF (IANZCH.EQ.0) FILENAME='TT:' OPEN (UNIT=1,FILE=FILENAME,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. 1ICH.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(1024A1) 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 C C------------------------------------------------------------------ C C WRITE TO CP/M FLOPPY C 3000 OPENFL=.FALSE. IFCTL=0 ! FIRST TIME WRITE NOTHING=.TRUE. TYPE 3129 3129 FORMAT('$VAX Input Filename: ') ACCEPT 15,IANZCH,FILENAME IF (IANZCH.EQ.0) GOTO 100 OPEN (UNIT=1,FILE=FILENAME,STATUS='OLD',ERR=3989, 1 FORM='FORMATTED',CARRIAGECONTROL='LIST') C CALL CPFI(NAME) ! INPUT CP/M FILENAME C CALL CPDIR (3,NAME,IRNUM,IDIR,IBLK,ISLO,IFCB) IF (IRNUM.EQ.-1) GOTO 100 ! FILE ALREADY EXISTS C C PAUSE 'CPMVAX - 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 NOTHING=.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,NAME,IFCTL,OPENFL,IERR) ! 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,NAME,IFCTL,OPENFL,IERR) ! 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,NAME,IFCTL,OPENFL,IERR) ! 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 (NOTHING) GOTO 3990 IF(K.LT.1024) GOTO 3186 CALL CPWOUT(IB,IDIR,IBLK,ISLO,IFCB,NAME,IFCTL,OPENFL,IERR) ! 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 ' CPMVAX : LAST OUT' C>>>>>> CALL CPWOUT(IB,IDIR,IBLK,ISLO,IFCB,NAME,-1,OPENFL,IERR) ! LAST BUFFER IF (IERR.EQ.1) GOTO 100 C CLOSE (UNIT=1) C GOTO 100 C 3989 TYPE *,' ?CPMVAX-W-VAX Input File Open error' 3990 TYPE 3991 3991 FORMAT(/' ?CPMVAX-W-VAX 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 END