C+
C DSCCPY.FTN
C
C THIS IS THE MAIN PROGRAM WHICH WILL RESTORE A SUBSET OF A DSC TAPE
C   TO DISK.
C
C EDITED JUNE 85 TO FIX BUG IF FIRST THING ON A TERMINAL LUN IS A READ FB
C USE LUN 5 FOR ALL TERMINAL IO
C
C INPUTS:  DSC TAPE UNMOUNTED ON LUN 3
C
C          PROMPT RESPONSES THROUGH LUN 5
C
C OUTPUTS: RESTORED FILE(S) ON LUN 4
C          PROMPTS ON LUN 5
C          LIST OF FILENAMES COPIED ON LUN 5
C
C SUBROUTINES REQUIRED:
C
C   USER SUPPLIED ROUTINES:
C
C      CKTAPE - CHECK TAPE STATUS RETURN FROM RDTAPE
C      DCONV  - CONVERT DATE STRING TO INTEGER EQUIVALENT (WB-004)
C               (REQUIRES IFSTEQ)
C      FIXFDB - PATCH UP FILE-DESCRIPTOR-BLOCK FROM OLD FILE HEADER
C               (REQUIRES SYSTEM ROUTINES)
C      ICPOS  - GET INDEX INTO STRING OF MATCHING CHARACTER
C      IDCMPR - COMPARE INTEGER VALUES OF DATES (WB-004)
C      IFSTEQ - FUNCTION TO SEE IF STRINGS MATCH (WITH WILDCARD)
C      NXTAPE - PROMPT USER TO LOAD NEXT INPUT TAPE
C               (REQUIRES SYSTEM ROUTINES)
C      PARSE  - SCAN INPUT LINE FOR FILENAME STRING
C      PPASC  - CONVERT BINARY TO PROGRAMMER-PROJECT NUMBER (UIC)
C               (REQUIRES SYSTEM ROUTINE)
C      RDTAPE - DO DIRECT QIO READ OF MAGTAPE
C               (REQUIRES SYSTEM ROUTINE)
C      UNSPAC - REMOVE ASCII WHITE SPACE FROM STRING
C      UPCASE - CONVERT INPUT STRING TO ALL UPPER CASE, 7-BIT ASCII
C
C   SYSTEM SUPPLIED ROUTINES REQUIRED:
C
C      ASSIGN - ASSIGN FORTRAN LUN TO DEVICE
C      ERRSET - SET CHARACTERISTICS OF FORTRAN FILE OPEN ERROR
C      ERRSNS - GET STATUS OF FORTRAN ERRORS
C      EXIT   - END OF PROGRAM
C      GETADR - RETURN ADDRESS OF BUFFER TO CALLER
C      R50ASC - CONVERT RADIX-50 TO ASCII STRING.
C      WTQIO  - SYSTEM LEVEL I/O CALL.
C
C DSCCPY VERSION 1.2
C
C  3-NOV-81 WB-005, DSCCPY -- MOVE CONFIRMATION MESSAGES TO LUN-5
C                   ADD FILES-COPIED COUNTER, FIX ERROR HANDLER
C  2-NOV-81 WB-004, DSCCPY, DCONV, IDCMPR -- ADD OPTION TO SELECT
C                   FILES BY CREATION DATE (BEFORE:, ON:, AFTER:)
C 28-AUG-81 WB-003, DSCCPY, NXTAPE -- DO NOT UNLOAD AFTER REWIND
C 23-JUN-81 WB-002, DSCCPY -- DON'T OVERWRITE EXISTING FILE
C 22-JUN-81 WB-001, NXTAPE -- SELECT 800 OR 1600 BPI DENSITY
C
C      10-MAY-81, W. D. BURTON, JR.
C                 TEXAS RESEARCH INSTITUTE OF MENTAL SCIENCES
C                 1300 MOURSUND
C                 HOUSTON, TEXAS  77030
C                 (713) 797-1976, EXT 501
C-
C
C
      PARAMETER IOWVB="11000
      BYTE DSCFIL(12), OUTFIL(35), INFIL(35), OUTBUF(512)
      BYTE UICS(9), TUIC(9), FNAMES(21), TFILEN(21), ANS
C
C WB-004 WORKING AREAS FOR DATE SELECTION
      PARAMETER NDOPTS=3
      BYTE DSTRNG(20), DOPTNS(6,NDOPTS)
      INTEGER IDT1(3), IDT2(3)
      LOGICAL IFDATE
C
      INTEGER HEADER(49), NFS(2), IPRL(6)
      INTEGER*4 NFSIZE
      LOGICAL IFWILD, IFCOPY, IFFID
C
C THE PARAMETER -NRLTH- CONTROLS THE SIZE OF THE INPUT TAPE BUFFER.
C  IF DATA-OVERRUN ERRORS OCCUR WHILE READING TAPE, MAKE -NRLTH-
C  LARGER.   -NRLTH- SHOULD NEVER BE LESS THAN 1040(10)
      PARAMETER NRLTH=2064, HDRLTH=16
C
      LOGICAL*1 BUF(NRLTH)
      INTEGER DSCHDR(HDRLTH/2), WORDS(NRLTH/2), DATA((NRLTH-HDRLTH)/2)
C
      INTEGER*4 NREC, NTOTB, NBUSE, NFILES
C
      EQUIVALENCE (BUF(1),DSCHDR(1)), (BUF(HDRLTH+1),DATA(1)),
     1  (BUF(1),WORDS(1))
C
      EQUIVALENCE (NFS(1), NFSIZE)
C
C WB-004 DATE OPTIONS
      DATA DOPTNS /'B','E','F','O','R','E', 'O','N',4*' ',
     1   'A','F','T','E','R',' '/
C
C FORMATS FOR TERMINAL OUTPUT
 1000 FORMAT (1H0, 'DSCCOPY - RETRIEVE FILES FROM DSC TAPE, V 1.2',/)
 1001 FORMAT (/ 1H$, 'ENTER DSC TAPE FILE NAME [A]   ')
C
 1100 FORMAT (1H0,'DSC OUTPUT TAPE FILE ', 12A1, ' IS NOT ON THIS REEL')
 1101 FORMAT (1H0, 'I/O ERROR', I4, ' DURING SEARCH FOR DSC OUTPUT',
     1   ' TAPE FILE')
 1200 FORMAT (/ 1H$, 'OUTPUT DEVICE AND UIC - DDU:[UIC]   ')
 1201 FORMAT (1H0 'FILE TO BE COPIED', / 1H , 'REMEMBER [UIC] IS',
     1   ' OWNING UIC, NAME IS NAME FROM HEADER', // 1H$,
     2   '[UIC]NAME.EXT;VER   ')
 1205 FORMAT (1H0, 'OUTPUT DEVICE MUST BE MOUNTED')
 1220 FORMAT (1H , 'BAD FILE NAME')
 1230 FORMAT (1H$, 'FILENAME CONTAINS WILD CHARACTERS, COPY MULTIPLE',
     1   ' FILES? [Y/N]   ')
 1250 FORMAT (1H0, 'MULTIPLE FILES WILL BE COPIED', / 1H , 2X,
     1   'SELECT BY CREATION DATE? [BEFORE: ON: AFTER: DD-MMM-YY]',
     2   / 1H , 2X, '<CR>-ONLY IMPLIES NO DATE SELECTION', /
     3   1H$, '?   ')
C
 1300 FORMAT (1H0 'COULD NOT LOCATE FILE ', 9A1, 21A1, /
     1  1H , 5X, 'IN VOLUME ', 12A1)
C
 1415 FORMAT (1H , 'FILE DID NOT START ON THIS REEL ', 35A1)
C
C WB-002
 1416 FORMAT (1H0, 'WARNING - FILE ALREADY EXISTS: ', 35A1)
 1417 FORMAT (1H , 5X, 'DO YOU WANT TO:', / 1H , 10X, 
     1   'C = COPY ANYWAY (OVERWRITE)', / 1H, 10X, 'S = SKIP COPYING',
     2   ' THIS FILE', / 1H , 10X, 'N = CREATE A NEW VERSION', /
     3   1H$, '?   ')
C END, WB-002
 1420 FORMAT (1H0, 'ERROR OPENING FILE ', 35A1)
 1435 FORMAT (1H , 'TAPE ERROR', I4, ' DURING FILE COPY')
 1436 FORMAT (1H0, 5X, 'FILE CONTINUES ON ANOTHER REEL')
C
C FORMATS FOR CONSOLE INPUT
 2000 FORMAT (Q, 12A1)
 2200 FORMAT (Q, 30A1)
 2201 FORMAT (Q, 35A1)
 2202 FORMAT (2O7)
 2230 FORMAT (A1)
 2250 FORMAT (Q, 30A1)
 2417 FORMAT (A1)
C
C FORMAT FOR INTERNAL ENCODE/DECODE
 3000 FORMAT (O6)
C
C WB-005 COPY CONFIRMATION MESSAGES
 5410 FORMAT (1H , 'BEGIN FILE ', 35A1)
 5500 FORMAT (1H, 'COMPLETE')
 5520 FORMAT (1H , 5X, I5, ' FILES COPIED', /)
 5800 FORMAT (1H0, '** ERROR OUTPUT FILE IS INCOMPLETE', / 
     1   1H , 5X, 35A1)
C
C INITIALIZE SWITCHES
   10 CONTINUE
      IFCOPY = .FALSE.
      IFWILD = .FALSE.
      IFFID = .FALSE.
      IFDATE = .FALSE.
C
C IDENTIFY PROGRAM AND PROMPT FOR TAPE INPUT
   20 CONTINUE
C
      WRITE (1,1000)
C CALL TO NXTAPE WITH IFERR=-999 MEANS NO REWIND BEFORE INPUT PROMPT
      IFERR = -999
   30 CONTINUE
      NFCOPY = 0
      CALL NXTAPE (5, 5, 3, IFERR)
C
C CHECK FOR EOF FROM TERMINAL
      IF (IFERR .EQ. -10) GO TO 990
C
C PROMPT FOR DSC TAPE FILE NAME
   40 CONTINUE
      WRITE (5,1001)
      READ (5,2000, END=990, ERR=40) NQV, (DSCFIL(I), I=1,MIN(12,NQV))
C
C IF NO RESPONSE, SKIP RIGHT TO PROMPT FOR OUTPUT DEV/UIC
      IF (NQV .LE. 0) GO TO 200
C
C GOT A RESPONSE, MAKE IT UPPER CASE ASCII AND PAD WITH SPACE TO 12 CHAR
      CALL UPCASE (DSCFIL, NQV)
      CALL UNSPAC (DSCFIL, NQV)
      IF (NQV .GE. 12) GO TO 59
      DO 50 I = NQV+1, 12
         DSCFIL(I) = ' '
   50 CONTINUE
   59 CONTINUE
C
C SEARCH INPUT TAPE FOR AN ANSI HDR1 LABEL MATCHING DSC FILE NAME
C
  100 CONTINUE
      NBYTES = NRLTH
C
C READ A RECORD
      CALL RDTAPE (3, NBYTES, BUF, IFERR)
C
C CHECK FOR ERRORS
      CALL CKTAPE (3, IFERR, NEOF, 1, 2)
C
C IF WE ARE AT DOUBLE TAPE MARK (NEOF=2) PUT OUT CANT FIND FILE MESSAGE
      IF (NEOF .NE. 2) GO TO 110
      WRITE (5,1100) DSCFIL
      GO TO 30
C
  110 CONTINUE
C IF NO ERROR, GO CHECK FOR ANSI
      IF (IFERR .GE. 0) GO TO 120
C
C ABORT PROGRAM IF EOF FROM TERMINAL
      IF (IFERR .EQ. -10) GO TO 990
C
C ELSE, UNDIAGNOSED ERROR, DISPLAY MESSAGE
      WRITE (5,1101) IFERR
      GO TO 100
C
C CHECK FOR ANSI RECORD (LENGTH = 80.)
  120 CONTINUE
      IF (NBYTES .NE. 80) GO TO 100
C
C GOT ANSI-LENGTH RECORD, IS IT A HDR1 RECORD
      IF (.NOT. IFSTEQ('HDR1', BUF(1), 4)) GO TO 100
C
C IT WAS, SEE IF FILE NAME MATCHES
      IF (.NOT. IFSTEQ(DSCFIL, BUF(5), 12)) GO TO 100
C
C IT MATCHED, RUN FORWARD 1 FILE MARK
  130 CONTINUE
      NBYTES = NRLTH
      CALL RDTAPE (3, NBYTES, BUF, IFERR)
      CALL CKTAPE (3, IFERR, NEOF, 1, 2)
      IF (NEOF .NE. 1) GO TO 130
C
C GOT A MATCHING DSC-FILE (LOCATED CORRECT PLACE ON TAPE
C
C PROMPT FOR OUTPUT DEVICE/UIC
  200 CONTINUE
      WRITE (5, 1200)
      READ (5, 2200, END=800, ERR=200) NQOUTF, (OUTFIL(I), I=1,NQOUTF)
C
C MAKE IT UPPER CASE AND ASCII
      CALL UPCASE (OUTFIL, NQOUTF)
      CALL UNSPAC (OUTFIL, NQOUTF)
      IF (NQOUTF .LE. 0) GO TO 200
C
C CHECK TO SEE THAT WE CAN ACCESS DISK (MUST BE MOUNTED)
C SHUT OFF FORTRAN ERROR
      CALL ERRSET (43, .TRUE., .FALSE., .FALSE., .FALSE.)
      CALL ERRSNS (I)
C
C TRY TO ACCESS DEVICE
      CALL ASSIGN (4, OUTFIL, NQOUTF)
C
C CHECK FOR ERROR
      CALL ERRSNS (I, J)
      IF (I .EQ. 0) GO TO 205
      IF (J .EQ. -16) WRITE (1,1205)
  205 CONTINUE
C
C CANCEL ASSIGNMENT AND RESTORE ERROR
      CALL ASSIGN (4)
      CALL ERRSET (43, .TRUE., .FALSE., .FALSE., .TRUE.)
C
C
C PROMPT FOR INPUT FILE
  210 CONTINUE
      IFFID = .FALSE.
      WRITE (5,1201)
      READ (5,2201,END=800,ERR=210) NQIN, (INFIL(I), I=1,MIN(34,NQIN))
C
C MAKE RESPONSE UPPER CASE ASCII
      CALL UPCASE (INFIL, NQIN)
      CALL UNSPAC (INFIL, NQIN)
      IF (NQIN .LT. 4) GO TO 210
C
C CHECK FOR COPY BY FILE-ID.
      IF (.NOT. IFSTEQ('/FI:', INFIL, 4) ) GO TO 220
C
C IT WAS REQUEST BY FILE-ID, DECODE THE LINE
      DECODE (NQIN-4, 2202, INFIL(5), ERR=210) NFN, NSN
      IFFID = .TRUE.
      GO TO 230
C
C NOT BY FILE-ID, PARSE OUT THE FILE-NAME.EXT;VER
  220 CONTINUE
      CALL PARSE (NQIN, INFIL, UICS, FNAMES, IFWILD, IFERR)
      IF (IFERR .GE. 0) GO TO 230
      WRITE (5,1220)
      GO TO 210
C
C AT THIS POINT, <OWNING-UIC> IS IN -UICS-, <FILENAME.EXT;VER> IS IN
C   -FNAMES-.
C
  230 CONTINUE
C
C MAKE ONE LAST SCAN FOR WILD-CHARACTERS, SEE IF WANT TO COPY MULTIPLE
C  FILES.
      IF(ICPOS(UICS,1,9,'?') .EQ. 0 .AND. ICPOS(FNAMES,1,21,'?') .EQ. 0)
     1   GO TO 290
C
      IF (.NOT.IFWILD) GO TO 290
C
  240 CONTINUE
      WRITE (5,1230)
      READ (5,2230, END=290, ERR=240) ANS
      CALL UPCASE (ANS, 1)
      IF (ANS .EQ. 'Y') IFWILD = .TRUE.
C
C WB-004 CREATION DATE SELECTION
      IF (.NOT. IFWILD) GO TO 290
C
  250 CONTINUE
      IFDATE = .FALSE.
      WRITE (5,1250)
      READ (5,2250, END=290, ERR=250) NQD, (DSTRNG(I), I=1,MIN(NQD,20))
      IF (NQD .GT. 20) GO TO 250
C
      CALL UPCASE (DSTRNG, NQD)
C
C SKIP DATE SELECTION IF NO ANSWER
      IF (NQD .LE. 0) GO TO 290
C
C LOOK FOR (:) OR (SPACE) TO DELIMIT OPTION
      NDST = ICPOS (DSTRNG, 1, NQD, ':')
      IF (NDST .EQ. 0) NDST = ICPOS (DSTRNG, 1, NQD, ' ')
C
C ERROR IF NOT FOUND
      IF (NDST .LE. 0) GO TO 250
C
C LOOK UP OPTION
      NDOPT = 0
      DO 252 K = 1, NDOPTS
         IF (IFSTEQ(DOPTNS(1,K),DSTRNG(1),NDST-1)) NDOPT = K
  252 CONTINUE
C
C ERROR IF NOT FOUND
      IF (NDOPT .EQ. 0) GO TO 250
C
C FIGURE LENGTH OF DATE PART OF INPUT LINE AND SAVE ITS START
      NQD = NQD - NDST
      NDST = NDST + 1
C
C CONVERT DATE STRING TO INTEGER EQUIVALENT
C RETURNS MONTH-DAY-YEAR AS INTEGERS TO ARRAY
      CALL DCONV (DSTRNG(NDST), NQD, IDT1, IFERR)
C
C CHECK FOR ERROR RETURN
      IF (IFERR .LE. 0) GO TO 250
C
C NO ERROR, SET DATE SELECT SWITCH ON
      IFDATE = .TRUE.
C
  259 CONTINUE
C
C END OF WB-004 DATE SELECT OPTION
C
  290 CONTINUE
C
C SEARCH FOR HEADER WITH MATCHING FILE NAME OR FILE ID
C
  300 CONTINUE
      NBYTES = NRLTH
      CALL RDTAPE (3, NBYTES, BUF, IFERR)
      CALL CKTAPE (3, IFERR, NEOF, 1, 2)
C
C CHECK FOR END-OF-FILE WHILE SEARCHING
      IF (NEOF .EQ. 1) GO TO 300
      IF (NEOF .EQ. 2) GO TO 305
C
C CHECK FOR ANSI EOF/EOV RECORDS
      IF (NBYTES .NE. 80) GO TO 310
C
C GOT ANSI RECORD, IS IT AN EOF
      IF (IFSTEQ('EOF', BUF, 3)) GO TO 305
C
C NOPE, IS IT AN EOV
      IF (.NOT. IFSTEQ('EOV', BUF, 3)) GO TO 300
C YUP.
  305 CONTINUE
C
C COULDNT FIND REQUESTED FILE.  PRINT ERROR IF NOT DOING WILDCARDS.
      IF (.NOT. IFWILD) WRITE (1,1300) UICS, FNAMES, DSCFILE
C
C IF CAME HERE BECAUSE OF EOV RECORD, PROMPT FOR ANOTHER REEL
      IF (.NOT. IFSTEQ('EOV', BUF(1), 3)) GO TO 530
      CALL NXTAPE (5, 5, 3, IFERR)
C
C ABORT RUN IF END-OF-FILE FROM TERMINAL
      IF (IFERR .EQ. -10) GO TO 990
      GO TO 300
C
C
C CHECK FOR A DSC FILE-START (CODE=2) RECORD
  310 CONTINUE
      IF (DSCHDR(2) .NE. 2) GO TO 320
C
C SAVE FILE SIZE FROM CODE-2 RECORD
      NFS(1) = DATA(46)
      NFS(2) = DATA(47)
C
C SAVE FILE ID FOR THIS LENGTH
      NFID = DSCHDR(5)
      NFSN = DSCHDR(6)
      GO TO 300
C
C CHECK FOR A DSC IMAGE OF FILES-11 FILE HEADER (CODE=4)
  320 CONTINUE
      IF (DSCHDR(2) .NE. 4) GO TO 300
C
C GOT A FILE HEADER, IS IT THE ONE WE WANT?
C  DECODE FILE NAME AND UIC FROM FILE HEADER
C
C IDOFSW = WORD OFFSET TO ID AREA (FROM FILE HEADER)
      IDOFSW = BUF(HDRLTH+1) .AND. "377
C
C PICK UP AND CONVERT PPN TO FULL UIC STRING
      CALL PPASC (DATA(5), 1, LT, TUIC)
C
C DECODE FILE NAME AND EXTENSION
      CALL R50ASC(9, DATA(IDOFSW+1), TFILEN(1))
      TFILEN(10) = '.'
C
      CALL R50ASC(3, DATA(IDOFSW+4), TFILEN(11))
      TFILEN(14) = ';'
C
C DECODE VERSION NUMBER
      ENCODE (6, 3000, TFILEN(15)) DATA (IDOFSW+5)
C
C MARK THE END OF THE FILENAME
      TFILEN(21) = 0
C
C IF SEARCHING BY FILE ID, SEE IF IT MATCHES, KEEP READING IF NOT
      IF (.NOT. IFFID) GO TO 330
      IF (NFN .EQ. DATA(2) .AND. NSN .EQ. DATA(3)) GO TO 380
C FAILED TO MATCH ON FILE-ID
      GO TO 300
C
C NOT SEARCHING BY FILE ID, SEE IF FILENAMES MATCH
  330 CONTINUE
C
C CHECK OWNING UIC
      IF (.NOT. IFSTEQ(UICS,TUIC,9)) GO TO 300
C
C CHECK FILENAME.EXT;VER
      IF (.NOT. IFSTEQ(FNAMES, TFILEN, 20)) GO TO 300
C
C MATCHED, LAST CHECK FOR DATE SELECTION, WB-004
  380 CONTINUE
C
      IF (.NOT. IFDATE) GO TO 390
C
C CONVERT FILE HEADER CREATION DATE TO INTEGER
      J = HDRLTH + (IDOFSW*2) + 26
      CALL UPCASE (BUF(J), 7)
      CALL DCONV (BUF(J), 7, IDT2, IFERR)
C
C SKIP SELECTION IF DATE ERROR
      IF (IFERR .LE. 0) GO TO 390
C
C SEE HOW THEY MATCH, J = -1 IF 1<2, 0 IF 1=2, +1 IF 1>2
      J = IDCMPR (IDT2, IDT1)
C
C IF -BEFORE- AND -BEFORE- SELECTED, DO COPY
      IF (J .LT. 0 .AND. NDOPT .EQ. 1) GO TO 390
C
C IF -ON- AND -ON- SELECTED, DO COPY
      IF (J .EQ. 0 .AND. NDOPT .EQ. 2) GO TO 390
C
C IF -AFTER- AND -AFTER- SELECTED DO COPY
      IF (J .GT. 0 .AND. NDOPT .EQ. 3) GO TO 390
C
C ELSE KEEP LOOKING FOR HEADER
      GO TO 300
C
C END OF WB-004 CREATION DATE SELECTION
  390 CONTINUE
C
C BUILD UP FILE NAME FOR OPEN
      DO 395 I = 1, 21
         OUTFIL(NQOUTF+I) = TFILEN(I)
  395 CONTINUE
      NQOPN = NQOUTF + 20
C
C  SAVE THE INPUT FILE HEADER (UP TO THE START OF THE MAP AREA)
C   WE WILL NEED IT LATER FOR FIXING UP NEW FILE HEADER
  400 CONTINUE
      DO 410 I = 1,49
         HEADER(I) = DATA(I)
  410 CONTINUE
C
C WB-002, FIX OVERWRITING OF FILE IF IT ALREADY EXISTS
C
C SHUT OFF ERROR LOG OF OPEN ERROR
      CALL ERRSET (29, .TRUE., .FALSE., .TRUE., .FALSE.)
      OPEN (UNIT=4, NAME=OUTFIL, TYPE='OLD', ERR=418)
C
C GETTING AN ERROR ON THE OPEN IS EXPECTED AND INDICATES FILE DOES NOT
C   EXIST.
C
C IF OPENED OK, THE FILE EXISTED, PRODUCE ERROR MESSAGE AND DECIDE WHAT
C  TO DO.
      CLOSE (UNIT=4)
  411 CONTINUE
      WRITE (5,1416) (OUTFIL(I), I=1,NQOPN)
      WRITE (5,1417)
      READ (5,2417,END=900, ERR=411) ANS
      CALL UPCASE (ANS, 1)
C
C DECODE ANSWER TYPE
C  IF ANSWER WAS 'C', COPY ANYWAY AND OVERWRITE
      IF (ANS .EQ. 'C') GO TO 418
C
C IF ANSWER WAS 'N', CREATE A NEW VERSION, ELSE SKIP
      IF (ANS .NE. 'N') GOTO 520
C
C FIND POINTER TO VERSION NUMBER DELIMITER (;)
      NQOPN = ICPOS(OUTFIL, 1, NQOPN, ';')
C TRIM OFF THE VERSION NUMBER
      OUTFIL(NQOPN) = 0
C
C CHECK TO BE SURE THAT WE HAVE CORRECT SIZE (MATCH FILE ID)
  418 CONTINUE
      IF (NFID .EQ. DSCHDR(5) .AND. NFSN .EQ. DSCHDR(6)) GO TO 419
      WRITE (5,1415) (OUTFIL(I), I=1,NQOPN)
      GO TO 510
C
C NOW CHECK FOR CONTIGUOUS FILE, ADJUST SIZE WORD FOR OPEN
  419 CONTINUE
      NFBLOK = NFSIZE
      IF ((HEADER(7) .AND. "200) .EQ. 0) NFSIZE = -NFSIZE
C
C OPEN THE OUTPUT FILE FOR QIO WRITES
      OPEN (UNIT=4, NAME=OUTFIL, TYPE='NEW', BUFFERCOUNT=0,
     1   INITIALSIZE=NFSIZE, EXTENDSIZE=0, ERR=420)
      WRITE (5,5410) (OUTFIL(I), I=1,NQOPN)
      GO TO 430
C
C PROCESS ERROR MESSAGE DURING OPEN, THEN ACT LIKE INPUT EOF
  420 CONTINUE
      WRITE (5,1420) (OUTFIL(I), I=1,NQOPN)
      GO TO 520
C
C OPEN OK, GET A DATA RECORD
  430 CONTINUE
      NOUT = 0
      IFCOPY = .TRUE.
      IPRL(4) = 0
      IPRL(5) = 0                   !LOW ORDER VBN
  435 CONTINUE
      NBYTES = NRLTH
      CALL RDTAPE (3, NBYTES, BUF, IFERR)
      CALL CKTAPE (3, IFERR, NEOF, 1, 2)
      IF (NEOF .EQ. 1) GO TO 435
      IF (NEOF .EQ. 2) GO TO 460
      IF (IFERR .LT. 0) WRITE (5, 1435) IFERR, (OUTFIL(I), I=1,NQOPN)
C
C CHECK FOR ANSI RECORD
      IF (NBYTES .NE. 80) GO TO 440
C
C IT WAS ANSI, SEE IF IT IS EOV (FOR CROSSING REEL)
      IF (IFSTEQ('EOF', BUF(1), 3)) GO TO 460
      IF (.NOT. IFSTEQ ('EOV', BUF(1), 3)) GO TO 440
C
C IT IS EOV, REWIND AND PROMPT FOR NEXT REEL
      WRITE (5,1436)
      CALL NXTAPE (5, 5, 3, IFERR)
C
C STOP ON EOF OR ERROR FROM CONSOLE
      IF (IFERR .EQ. -10) GO TO 460
C
  440 CONTINUE
      IF (DSCHDR(2) .NE. 1) GO TO 435
C
C MAKE SURE FILE ID NUMBERS MATCH
      IF (DSCHDR(5) .NE. HEADER(2)) GO TO 435
      IF (DSCHDR(6) .NE. HEADER(3)) GO TO 435
C
      DO 459 I = HDRLTH+1, NBYTES
         NOUT = NOUT + 1
         OUTBUF(NOUT) = BUF(I)
         IF (NOUT .LT. 512) GO TO 459
C OUTPUT RECORD IS FULL, WRITE TO FILE
         CALL GETADR (IPRL(1), OUTBUF)
         IPRL(2) = 512
         IPRL(5) = IPRL(5) + 1
         IF (IPRL(5) .EQ. 0) IPRL(4) = IPRL(4) + 1
         CALL WTQIO (IOWVB, 4, 4, 0, IOSB, IPRL, IDS)
         NOUT = 0
C
C COUNT DOWN NUMBER OF BLOCKS TO WRITE
         NFBLOK = NFBLOK - 1
         IF (NFBLOK .LE. 0) GO TO 500
  459 CONTINUE
      GO TO 435
C
  460 CONTINUE
      IF (NFBLOK .NE. 0) WRITE (5,5800) (OUTFIL(I), I=1,NQOPN)
C
C FINISHED WRITING, FIX FDB USING FORMER HEADER AND CLOSE FILE
  500 CONTINUE
      CALL FIXFDB (4, HEADER, IFERR)
      CLOSE (UNIT=4)
      NFCOPY = NFCOPY + 1
      WRITE (5,5500)
      IFCOPY = .FALSE.
  510 CONTINUE
C
C IF NOT DOING A WILDCARD COPY, ALL DONE
  520 CONTINUE
      IF (IFWILD) GO TO 300
C
  530 CONTINUE
      WRITE (5,5520) NFCOPY
      IFERR = 0          !SET TO FORCE NEXT-TAPE PROMPT
      GO TO 30
C
C FINISH UP AND EXIT
  800 CONTINUE
      IF (.NOT.IFCOPY) GO TO 30
      WRITE (5,5800) (OUTFIL(I), I=1,NQOPN)
      GO TO 30
C
  900 CONTINUE
  990 CONTINUE
      CALL EXIT
      END
