C THIS PROGRAM MAY BE USED TO COPY FILES FROM ONE TAPE TO ANOTHER OR C FROM DISC TO TAPE OR FROM TAPE TO DISC WITH CONVERSION AND/OR C REBLOCKING OF THE DATA C WHEN CHOOSING YOUR OUTPUT RECORD LENGTH BE SURE THAT THE SUM OF C THE INPUT RECORD LENGTH AND THE OUTPUT RECORD LENGTH IS LESS C THAN 32768 UNLESS THE INPUT AND THE OUTPUT RECORD LENGTHS ARE C EXACT MULTIPLES OF EACH OTHER. LOGICAL*1 TT,DT,TD,IST1,BUF,ISTH,ISTL,FILNAM INTEGER*2 IDRV,ODRV,IBPI,OBPI,IFILE,OFILE,NFILES,IRECL,ISWAP INTEGER*2 IBUF,IFORM,ICONVT,ORECL,OLEN,OFIL,OCHA REAL*8 R8BUF DIMENSION IST(2),IST1(2),BUF(32000),IBUF(16000),RBUF(8000) DIMENSION R8BUF(4000),IM(8),FILNAM(30) EQUIVALENCE (IST,IST1),(IST(2),IST2),(IST1(1),ISTL),(IST1(2),ISTH) EQUIVALENCE (BUF,IBUF,RBUF,R8BUF) DATA MAX,IM,IEOF/32000,1,1,2,4,4,4,8,8,-10/ C FIRST ASK A WHOLE BUNCH OF QUESTIONS TO FIND OUT THE USERS REQUEST 1 WRITE(5,100) 100 FORMAT(' ENTER FUNCTION CODE ',/,' 0=EXIT',/,' 1=TAPE TO TAPE',/, 1 ' 2=TAPE TO DISC',/,' 3=DISC TO TAPE') READ(5,*)I IF(I .EQ. 0) GO TO 200 IF(I .LT. 0) GO TO 1 IF( I .GT. 3) GO TO 1 TT=.FALSE. TD=.FALSE. DT=.FALSE. IF(I .EQ. 1) TT=.TRUE. IF(I .EQ. 2) TD=.TRUE. IF(I .EQ. 3) DT=.TRUE. 2 WRITE(5,110) 110 FORMAT(' ENTER CONVERSION CODE ',/,' 0=NO CONVERSION',/, 1 ' 1=EBCDIC TO ASCII',/,' 2=ASCII TO EBCDIC',/, 2 ' 3=I*2 360 TO 11-70 OR 1170 TO 360',/, 3 ' 4=I*4 360 TO 11-70 OR 11-70 TO 360',/, 4 ' 5=360 R*4 TO 11-70 R*4',/,' 6=11-70 R*4 TO 360 R*4',/, 5 ' 7=360 R*8 TO 11-70 R*8',/,' 8=11-70 R*8 TO 360 R*8') READ(5,*)ICONVT IF(ICONVT .LT. 0) GO TO 2 IF(ICONVT .GT. 8) GO TO 2 C NOW WE KNOW APROXIMATELY WHAT THE USER WANTS SO LETS SET UP C THE INPUT UNIT IF(DT)GO TO 10 C HERE FOR INPUT FROM A MAGNETIC TAPE 5 WRITE(5,101) 101 FORMAT(' ENTER INPUT DRIVE,BITS PER INCH AND INITIAL FILE ' 1 ,'POSITION') READ(5,*)IDRV,IBPI,IFILE C NOW MOUNT THE TAPE AND SET THE CHARACTORISTICS C FIRST CHECK THE USERS INPUT TO SEE IF IT IS REASONABLE IF(IDRV .LT. 0 .OR. IDRV .GT. 3) GO TO 5 IF(IBPI .NE. 800 .AND. IBPI .NE. 1600)GO TO 5 IF(IFILE .LT. 1) GO TO 5 C HERE WITH A REASONABLE REQUEST ICHA=0 IF(IBPI .EQ. 1600)ICHA=2048 CALL MTINIT(1,IDRV,ICHA,IST) C INITIALIZE FILE AND RECORD COUNTERS IFIL=1 IREC=0 IF(IFILE .EQ. IFIL) GO TO 7 6 CALL MTREAD(1,BUF,MAX,IST) IREC=IREC+1 IF(ISTL .EQ. 1)GO TO 6 IF(ISTL .NE. IEOF)WRITE(5,113)ISTL 113 FORMAT(' READ ERROR ',I5,' WILL BE HANDLED AS AN EOF') IREC=IREC-1 WRITE(5,103)IFIL,IREC IFIL=IFIL+1 103 FORMAT(' EOF ON FILE ',I2,' AFTER ',I5,' RECORDS') IREC=0 IF(IFIL .NE. IFILE) GO TO 6 C HERE WHEN WE ARE POSITIONED FOR THE FIRST REAL READ 7 NFILES=1 C IF(TD)GO TO 25 WRITE(5,104) 104 FORMAT(' ENTER NUMBER OF FILES TO BE COPIED ') READ(5,*)NFILES C CHECK FOR A REASONABLE INPUT IF(NFILES .LT. 1) GO TO 7 GO TO 25 C HERE TO SET UP FOR INPUT FROM A DISC FILE 10 WRITE(5,105) 105 FORMAT(' ENTER FORM OF DISC FILE AND RECORD LENGTH(BYTES)',/ 1 ,' 0=FORMATTED',/,' 1=UNFORMATTED') READ(5,*)IFORM,IRECL C CHECK FOR REASONABLE NUMBERS IF(IFORM .NE. 0 .AND. IFORM .NE. 1) GO TO 10 IF(IRECL .LT. 1) GO TO 10 IF(ICONVT .EQ. 0) GO TO 11 IF(MOD(IRECL,IM(ICONVT)) .NE. 0) GO TO 10 11 WRITE(5,106) READ(5,107)NCHAR,FILNAM FILNAM(NCHAR+1)=0 106 FORMAT(' ENTER FILE NAME ') 107 FORMAT(Q,30A1) C NOW OPEN THE FILE IF(IFORM .EQ. 0)OPEN(UNIT=4,NAME=FILNAM,TYPE='OLD' 1 ,CARRIAGECONTROL='LIST') IF(IFORM .EQ. 1)OPEN(UNIT=4,NAME=FILNAM,TYPE='OLD', 1 FORM='UNFORMATTED') C HERE WHEN WE ARE READY FOR INPUT NOW GET READY FOR OUTPUT 25 IF(TD) GO TO 50 C HERE WHEN THE OUTPUT IS TO A MAGNETIC TAPE WRITE(5,108) 108 FORMAT(' ENTER OUTPUT DRIVE,BITS PER INCH AND INITIAL FILE ' 1 ,'POSITION') READ(5,*)ODRV,OBPI,OFILE IF(ODRV .LT. 0 .OR. ODRV .GT. 3)GO TO 25 IF(TT .AND. ODRV .EQ. IDRV) GO TO 25 IF(OBPI .NE. 800 .AND. OBPI .NE. 1600) GO TO 25 IF(OFILE .LT. 1) GO TO 25 OFIL=1 IREC=0 OCHA=0 IF(OBPI .EQ. 1600)OCHA=2048 CALL MTINIT(2,ODRV,OCHA,IST) IF(OFIL .EQ. OFILE)GO TO 30 27 CALL MTREAD(2,BUF,MAX,IST) IREC=IREC+1 IF(ISTL .EQ. 1)GO TO 27 IF(ISTL .NE. IEOF)WRITE(5,113)ISTL IREC=IREC-1 WRITE(5,103)OFIL,IREC OFIL =OFIL+1 IF(OFIL .NE. OFILE) GO TO 27 30 WRITE(5,109) 109 FORMAT(' ENTER OUTPUT RECORD LENGTH',/, 1 ' MUST BE 0 OR AN EVEN NUMBER .GE. 14 .AND. .LE. 32000') READ(5,*)ORECL IF(ORECL .EQ. 0) GO TO 60 IF(ORECL .LT. 14) GO TO 30 IF(ORECL .GT. 32000) GO TO 30 IF(MOD(ORECL,2) .EQ. 1) GO TO 30 IF(ICONVT .EQ. 0 ) GO TO 60 IF(MOD(ORECL,IM(ICONVT)) .NE. 0) GO TO 30 GO TO 60 50 WRITE(5,105) READ(5,*)IFORM,ORECL IF(IFORM .NE. 0 .AND. IFORM .NE. 1)GO TO 50 IF(ORECL .LT. 0) GO TO 50 IF(ORECL .GT. 32767) GO TO 50 IF(ICONVT .EQ. 0) GO TO 51 IF(MOD(ORECL,IM(ICONVT)) .NE. 0) GO TO 50 51 WRITE(5,106) READ(5,107)NCHAR,FILNAM FILNAM(NCHAR+1)=0 IF(IFORM .EQ. 0)OPEN(UNIT=4,NAME=FILNAM, 1 CARRIAGECONTROL='LIST') IF(IFORM .EQ. 1)OPEN(UNIT=4,NAME=FILNAM,FORM='UNFORMATTED') C HERE WHEN WE ARE READY FOR BOTH INPUT AND OUTPUT SO BEGIN 60 DO 90 I=1,NFILES IPOS=1 IWPOS=1 C FIRST READ STORING THE DATA IN BUF 61 IF(DT)GO TO 65 CALL MTREAD(1,BUF(IPOS),MAX,IST) IF(ISTL .EQ. IEOF)GO TO 705 IF(ISTL .NE. 1)WRITE(5,113)ISTL IF(ISTL .NE. 1)GO TO 705 IPOS=IPOS + IST2 GO TO 70 65 IF(IFORM .EQ. 0)READ(4,111,END=705)(BUF(J),J=IPOS,IPOS+IRECL-1) IF(IFORM .EQ. 1)READ(4,END=705)(BUF(J),J=IPOS,IPOS+IRECL-1) IPOS=IPOS+IRECL 111 FORMAT(A1) C HERE CHECK TO SEE IF ENOUGH IS STORED UP TO PROCEED TO THE OUTPUT AND C CONVERSION PROCESS 70 IF(IPOS .LT. (ORECL+IWPOS))GO TO 61 705 IF(IPOS .EQ. 1)GO TO 88 C NOW WE HAVE ENOUGH DATA IN THE BUFFER C SET UP OUTPUT RECORD LENGTH OLEN=ORECL IF(OLEN .EQ. 0 .OR. (IPOS .LT. (ORECL+IWPOS)))OLEN =IPOS-IWPOS C CONVERT THE DATA IF NECESSARY IF(ICONVT .EQ. 0) GO TO 84 IF(ICONVT-2)71,72,73 71 CALL EBCASC(BUF,IWPOS,BUF,IWPOS,OLEN) GO TO 84 72 CALL ASCEBC(BUF,IWPOS,BUF,IWPOS,OLEN) GO TO 84 73 CALL SWABI(BUF(IWPOS),OLEN) IW=1+IWPOS/IM(ICONVT) NW=IW+OLEN/IM(ICONVT) -1 GO TO (84,84,84,74,76,78,80,82),ICONVT C HERE FOR THE I*4 CONVERSION 74 DO 75 J=IW,NW,2 ITEMP=IBUF(J) IBUF(J)=IBUF(J+1) 75 IBUF(J+1)=ITEMP GO TO 84 C HERE FOR THE 360 TO 1170 R*4 CONVERSION 76 DO 77 J=IW,NW 77 RBUF(J)=TPDPFS(RBUF(J)) GO TO 84 C HERE FOR THE 1170 TO 360 R*4 CONVERSION 78 DO 79 J=IW,NW 79 RBUF(J)=TIBMFS(RBUF(J)) GO TO 84 C HERE FOR THE 360 TO 1170 R*8 CONVERSION 80 DO 81 J=IW,NW 81 R8BUF(J)=TPDPFD(R8BUF(J)) GO TO 84 C HERE FOR THE 1170 TO 360 R*8 CONVERSION 82 DO 83 J=IW,NW 83 R8BUF(J)=TIBMFD(R8BUF(J)) 84 IF(TD) GO TO 85 J=OLEN IF(J .LT. 14)J=14 IF(MOD(J,2).EQ.1)J=J+1 CALL MTWRIT(2,BUF(IWPOS),J,IST) C WHEN WRITING ON TAPE OBSERVE THE MINIMUM RECORD SIZE AND THE C RULE AGAINST WRITING AN ODD NUMBER OF BYTES. IF(ISTL .NE. 1)WRITE(5,114)ISTL 114 FORMAT(' TAPE WRITE ERROR ',I5,' ERROR IGNORED ') GO TO 86 85 IF(IFORM .EQ. 0)WRITE(4,112)(BUF(J),J=IWPOS,OLEN+IWPOS-1) 112 FORMAT(A1) IF(IFORM .EQ. 1) WRITE(4)(BUF(J),J=IWPOS,OLEN+IWPOS-1) 86 IWPOS=IWPOS+OLEN IF((IWPOS + OLEN-1) .LT. IPOS)GO TO 70 IPOS=1+IPOS-IWPOS IWPOS=1 IF(IPOS-1)88,61,87 87 CALL MOVE(BUF,OLEN+1,BUF,1,IPOS-1) GO TO 70 88 IF(TD)GO TO 90 CALL MTWEOF(2,IST) 90 CONTINUE IF(DT) GO TO 92 CALL MTREWD(1,IST) 92 IF(TD)GO TO 200 CALL MTWEOF(2,IST) CALL MTREWD(2,IST) 200 STOP END