	PROGRAM FOREIGN
C
C     TAPECOPY PROGRAM
C 
C     PROGRAM WILL READ UNLABELED MAGTAPES CONTAINING FIXED LENGTH
C             RECORDS.  TAPE FILES ARE DEBLOCKED, AND WRITTEN TO DISK 
C             OPTIONALLY, TRAILING SPACES AND CARD SEQUENCE FIELDS
C             CAN BE STRIPPED OFF, AND EBCDIC CODES TRANSLATED TO ASCII 
C 
C     **********************************************************
      PARAMETER BUFSIZE=8192          !INPUT WORKING BUFFER SIZE
C 
      PARAMETER EOF='879'X
      PARAMETER NOLOGNAM='908'X       !RETURN CODE
      PARAMETER NOPRIV = '24'X        !RETURN CODE
      PARAMETER IO$_READLBLK = '21'X  !READ LOGICAL BLOCK CODE FOR QIO
      PARAMETER IO$_REWIND   = '24'X  !REWIND FUNCTION CODE FOR QIO 
C 
      INTEGER*2 CHANNEL,ENDFLAG,IOSB(4) 
      INTEGER*4 SYS$ASSIGN,SYS$QIOW,RETCODE,OUTRECD 
      CHARACTER OUTFILE*13,BUFFER*8192
      CHARACTER CARDS*1,TRANS*1,STRIP*1,CODE*1
      CHARACTER ANSWER*1
C     *************************************************************** 
C     SETUP 
C 
      WRITE(6,*)' THIS PROGRAM READS INPUT FROM LOGICAL NAME "TAPE"'
      RETCODE=SYS$ASSIGN('TAPE',CHANNEL,,)
      IF(RETCODE.NE.1) GO TO 9000 
      PARAMS = 0      !NO PARAMETERS SET YET
      NUMFILE=1 
      ENDFLAG=0 
C 
C     REWIND THE TAPE 
C      RETCODE = SYS$QIOW(,%VAL(CHANNEL),%VAL(IO$_REWIND),IOSB,,,,,,,,)
C      IF (RETCODE .NE. 1) GO TO 9000
C 
C     ************************************************************* 
C     PREPARE FOR OUTPUT
C 
5     WRITE(6,*)' ENTER "FILENAME.TYP" OR "STOP" OR "SKIP"' 
      READ(5,1000)OUTFILE 
1000  FORMAT(A) 
C 
C     TEST TO SEE IF WE'RE DONE 
      IF (OUTFILE .EQ. 'STOP') THEN 
              STOP 'USER REQUESTED EXIT'
              ENDIF 
C 
C     SHOULD WE SKIP OVER SOME FILES? 
      IF (OUTFILE .EQ. 'SKIP') THEN 
              WRITE (6,*) ' HOW MANY FILES DO YOU WANT TO SKIP ?' 
              READ (5,2000) NUMFILES
              DO 8 I=1,NUMFILES 
7             RETCODE=SYS$QIOW(,%VAL(CHANNEL),%VAL(IO$_READLBLK),IOSB,,,
     2               %REF(BUFFER(1:1)),%VAL(BUFSIZE),,,,)
              IF (IOSB(1) .EQ. EOF .OR. IOSB(2).EQ.0) THEN
C                     LAST READ WAS EOF ... TEST FOR EOT (=2 EOF'S) 
                      IF (ENDFLAG .NE. 0) THEN
                              STOP 'END OF TAPR'
                              ELSE
                              ENDFLAG = 1 !ONE EOF SEEN 
                              NUMFILE = NUMFILE + 1 
                              GO TO 8         !COUNT ONE FILE 
                              ENDIF 
                      ENDIF 
              ENDFLAG = 0     !NOT END OF FILE
              GO TO 7         !CONTINUE READING TO END OF FILE
8             CONTINUE
              GO TO 5 
              ENDIF 
C     ************************************************************* 
C     GET PARAMETERS FOR THE TAPECOPY 
C 
      IF (PARAMS .EQ. 1 ) GO TO 20
C 
      WRITE(6,*)' ***** ENTER TAPE-COPY PROCESSING PARAMETERS *****'
      TRANS = 'N' 
      STRIP = 'N' 
      OUTRECD = 80
      WRITE(6,*)' ARE THE FILES 80 CHAR CARD IMAGES (Y/N)?' 
      READ (5,1000) CARDS 
      IF (CARDS .NE. 'Y' ) THEN 
              CARDS = 'N' 
10            WRITE(6,*) ' ENTER OUTPUT RECORD SIZE'
              READ(5,2000)OUTRECD 
2000          FORMAT(I4)
              IF(OUTRECD.GT.BUFSIZE)THEN
                      WRITE(6,*)' RECORD SIZE TOO LARGE ' 
                      GO TO 10
                      END IF
              IF(OUTRECD.LE.0)THEN
                              OUTRECD=80
                              WRITE(6,*) ' 80 CHAR RECORD ASSUMED'
                              END IF
              ENDIF 
C 
      WRITE(6,*) ' TRANSLATE INPUT TO ASCII (Y/N) ?'
      READ (5,1000) TRANS 
      IF (TRANS .NE. 'Y' ) THEN 
                      TRANS = 'N' 
              ELSE
2500                  WRITE(6,*) ' FROM EBCDIC OR BCD (E/B)?' 
                      READ (5,1000) CODE
                      IF((CODE.NE.'E').AND.(CODE.NE.'B')) GO TO 2500
              ENDIF 
C 
      IF (CARDS .EQ. 'Y' ) THEN 
              WRITE(6,*) ' STRIP TRAILING BLANKS (Y/N) ?' 
              READ (5,1000) STRIP 
              IF (STRIP .NE. 'Y' ) THEN 
                      STRIP = 'N' 
                      ENDIF 
      ENDIF 
      PARAMS = 1              !PARAMETERS NOW INITIALIZED 
C 
C     ********************************************************
C     PREPARE THE OUTPUT FILE 
C 
20    IBLKSIZE = 0
      NUMRECS=0 
      ISTART = 1
      IREMAIN = 0 
      OPEN(UNIT=1,NAME=OUTFILE,CARRIAGECONTROL='LIST',STATUS='NEW',
     2               RECORDSIZE=OUTRECD) 
C 
C     ********************************************************* 
C     GET AN INPUT RECORD 
C 
50    BUFFER(ISTART:BUFSIZE) = ' '    !CLEAR INPUT BUFFER 
      IF ((IBLKSIZE+IREMAIN) .GT. BUFSIZE) STOP 'INPUT RECORD TOO LARGE'
      RETCODE=SYS$QIOW(,%VAL(CHANNEL),%VAL(IO$_READLBLK),IOSB,,,
     1       %REF(BUFFER(ISTART:ISTART)),%VAL(BUFSIZE),,,,)
      IF(RETCODE.NE.1)GO TO 9000
C 
C     CHECK FOR EOF 
      IF(IOSB(1).EQ.EOF.OR.IOSB(2).EQ.0)THEN
C 
C        TEST FOR END OF TAPE 
         IF(ENDFLAG.NE.0)THEN 
              STOP 'END OF TAPE'
         ELSE 
              ENDFLAG=1 
              CLOSE(UNIT=1) 
              WRITE(6,4000)NUMFILE,NUMRECS
4000          FORMAT(' END OF FILE # ',I8,': ',I8,' RECORDS WRITTEN') 
              NUMFILE = NUMFILE + 1 
              GO TO 5 !GET READY FOR NEXT INPUT FILE
         END IF 
      END IF
C 
C     **********************************************************
C     DE-BLOCK AND WRITE OUTPUT RECORDS 
      ENDFLAG = 0     !CLEAR EOF. WE'RE NOW IN A NEW FILE 
      IF(IOSB(2).LT.OUTRECD)THEN
              WRITE(6,4100)IOSB(2)
4100          FORMAT(' REC HAS ',I4,'BYTES...IGNORE IT')
              GO TO 50
              END IF
      IBLKSIZE = IOSB(2)      !SIZE OF INPUT DATA PHYSICAL RECORD 
      NUMBYTES = IBLKSIZE + IREMAIN !TOTAL # OF CHARS IN BUFFER 
      IREMAIN = NUMBYTES      !# OF INPUT CHARS REMAINING TO PROCESS
      DO 60 I=1,NUMBYTES,OUTRECD
C     TEST FOR PARTIAL REMAINING RECORD 
      IF (IREMAIN .LT. OUTRECD) THEN
              IF (IREMAIN .GT. 0) THEN
              BUFFER(1:IREMAIN) = BUFFER((NUMBYTES-IREMAIN+1):NUMBYTES) 
              ENDIF 
              ISTART = IREMAIN+1
              GO TO 50
              ENDIF 
C 
      NUMRECS=NUMRECS+1 
      IF (TRANS .EQ. 'Y') THEN
              IF (CODE .EQ. 'E') THEN 
                 CALL ETRANS(OUTRECD,%REF(BUFFER(I:I))) 
              ELSE
                 CALL BTRANS(OUTRECD,%REF(BUFFER(I:I))) 
              ENDIF 
         ENDIF
      K = I+OUTRECD-1 !END OF OUTPUT RECORD 
      IF (STRIP .EQ. 'Y') THEN
              DO 55 K = I+71 , I , -1  !IGNORE COL 73-80
              IF (BUFFER(K:K) .NE. ' ') THEN
                      GO TO 57
                      ENDIF 
55            CONTINUE
57            CONTINUE
              ENDIF 
C 
C 
              WRITE(1,5000)BUFFER(I:K)
C 
      IF (MOD(NUMRECS,100) .EQ. 0) THEN 
              WRITE(6,4200) NUMRECS 
4200          FORMAT(' RECORD: ',I8)
              ENDIF 
      IREMAIN = NUMBYTES-(I+OUTRECD-1)        !UPDATE REMAINING CHAR COUNT
C 
60    CONTINUE
5000  FORMAT(A) 
      GO TO 50
C 
C     ************************************************************* 
C     ERROR PROCESSING
9000  IF (RETCODE .EQ. NOLOGNAM) THEN 
              WRITE(6,*)' ********************************' 
              WRITE(6,*)' LOGICAL NAME "TAPE" NOT ASSIGNED' 
              WRITE(6,*)' ********************************' 
              ENDIF 
      IF (RETCODE .EQ. NOPRIV) THEN 
              WRITE(6,*)' ***********************************'
              WRITE(6,*)' "TAPE" MUST BE MOUNTED/FOREIGN' 
              WRITE(6,*)' ***********************************'
              ENDIF 
              WRITE(6,3000)RETCODE
3000          FORMAT(' ******************************************'/ 
     2               ' SYSTEM CALL RETURN CODE = ',Z8,' HEX'/
     3              ' ******************************************') 
      END 
