PROGRAM FTCOPY
C
C  THIS PROGRAM ALLOWS COPYING OF A SPECIFIED NUMBER OF FOREIGN TAPE FILES
C
C
C  BUFFERS AND SUCH
C
      INTEGER*2 IOSB(4)
      BYTE IBUF(32768)
C
C  EXTERNAL STUFF
C
      INTEGER SYS$ASSIGN, SYS$QIOW
      EXTERNAL IO$_READLBLK, IO$_WRITELBLK, IO$_WRITEMARK
      INTEGER*2 SS$_NORMAL, SS$_ENDOFFILE
      PARAMETER (SS$_NORMAL='0001'X)
      PARAMETER (SS$_ENDOFFILE='0870'X)
C
C  MISCELLANEOUS IMPEDIMENTIA
C
      INTEGER*2 CHANI, CHANO, RECSIZE, I1, EOFCNT
      CHARACTER*1 A1
      LOGICAL FIRST /.TRUE./
      INTEGER ISIZE/32767/,I2/0/
C
C  STARTUP
C
      EOFCNT=0
      WRITE (6,9000)
9000  FORMAT (' FTCOPY-FOREIGN TAPE COPY PROGRAM')
100   CONTINUE
      WRITE (6,9001)
9001  FORMAT (' COPY FILES [C] OR QUIT [Q]?')
      READ (5,9002) A1
9002  FORMAT (A1)
      IF (A1 .EQ. 'Q') GOTO 7000
      WRITE (6,9003)
9003  FORMAT (' ENTER NUMBER OF FILES TO COPY')
      READ (5,9004) I1
9004  FORMAT (I2)
      IF (I1 .EQ. 0) GOTO 7000
C
C  INITIALIZE TAPE UNITS
C
      IF (.NOT. FIRST) GOTO 1000
      FIRST = .FALSE.
C  ASSIGN INPUT TAPE
      I= SYS$ASSIGN('INPUT',CHANI,,)
      IF (I .EQ. SS$_NORMAL) GOTO 20
C  ASSIGN ERROR
      WRITE (6,9006) I
9006  FORMAT (' FTCOPY-INPUT TAPE ASSIGN ERROR=',Z4)
      GOTO 8000
C  ASSIGN OUTPUT TAPE
20    I = SYS$ASSIGN('OUTPUT',CHANO,,)
      IF (I .EQ. SS$_NORMAL) GOTO 40
C  ASSIGN ERROR
      WRITE (6,9007) I
9007  FORMAT (' FTCOPY-OUTPUT TAPE ASSIGN ERROR=',Z4)
      GOTO 8000
40    CONTINUE
C
C  COPY "I1" FILES
C
1000  CONTINUE
      DO 1200 I=1,I1
C
C  READ THE TAPE
C
1100  CONTINUE
      I2 = SYS$QIOW(,%VAL(CHANI),%VAL(%LOC(IO$_READLBLK)),IOSB,,,
     +IBUF,%VAL(ISIZE),,,,)
      IF (IOSB(1) .EQ. SS$_NORMAL) GOTO 1150
      IF (IOSB(1) .EQ. SS$_ENDOFFILE) GOTO 1120
C  ERROR IN READ
      WRITE (6,9020) IOSB(1)
9020  FORMAT (' FTCOPY-READ ERROR, IOSB=',Z4)
      GOTO 7000
C  END OF FILE, WRITE EOF ON OUTPUT
1120  CONTINUE
      TYPE *,' FTCOPY - EOF ENCOUNTERED'
      EOFCNT = EOFCNT+1
      I2 = SYS$QIOW(,%VAL(CHANO),%VAL(%LOC(IO$_WRITEMARK)),IOSB,,,,,,,,)
      IF (IOSB(1) .EQ. SS$_NORMAL) GOTO 1130
C  EOF ERROR
      WRITE (6,9030) IOSB(1),I2
9030  FORMAT (' FTCOPY-EOF ERROR ON OUTPUT, IOSB=',Z4,' I2=',I4)
      GOTO 8000
C  SEE IF THERE HAVE BEEN > 1 CONSECUTIVE EOF'S
1130  CONTINUE
      IF (EOFCNT .LT. 2) GOTO 1160
      WRITE (6,9032) EOFCNT
9032  FORMAT (' FTCOPY-',I2,' CONSECUTIVE EOFS READ, POSSIBLE END 
     +OF VOLUME')
      WRITE (6,9033)
9033  FORMAT ('     ENTER PROCEED [P] OR QUIT [Q]')
      READ (5,9002) A1
      IF (A1 .EQ. 'Q') GOTO 7000
      GOTO 1160
C
C  WRITE THE RECORD
C
1150  CONTINUE
      EOFCNT = 0
      RECSIZE = IOSB(2)
      I2 = SYS$QIOW(,%VAL(CHANO),%VAL(%LOC(IO$_WRITELBLK)),IOSB,,,
     +IBUF,%VAL(RECSIZE),,,,)
      IF (IOSB(1) .EQ. SS$_NORMAL) GOTO 1100
C  WRITE ERROR
      WRITE (6,9040) IOSB(1)
9040  FORMAT (' FTCOPY-WRITE ERROR, IOSB=',Z4)
      GOTO 7000
C
C  END OF COPY LOOP
C
1160  CONTINUE
1200  CONTINUE
      WRITE (6,9045) I1
9045  FORMAT  (' FTCOPY-',I2,' FILES COPIED')
      GOTO 100
C
C  WRITE ONE MORE FILE MARK AND EXIT
C
7000  CONTINUE
      I2 = SYS$QIOW(,%VAL(CHANO),%VAL(%LOC(IO$_WRITEMARK)),IOSB,,,,,,,,)
      I2 = SYS$QIOW(,%VAL(CHANO),%VAL(%LOC(IO$_WRITEMARK)),IOSB,,,,,,,,)
8000  CONTINUE
      WRITE (6,9090)
9090  FORMAT (' FTCOPY EXITING')
      CALL EXIT
      END