FTN4,L
C 
C     NAME: MERGE 
C     SOURCE: 92067-18334 
C     RELOC:  92067-16334 
C     PGMR:   R.D.
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  ALL RIGHTS     *
C  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
C  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
C  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
C  ***************************************************************
C 
C 
C 
      PROGRAM MERGE (3,90),92067-16334 REV.2013 791206
C 
C 
      LOGICAL NAMR,IN 
      DIMENSION INAMT(2),MERG(5)
      DIMENSION INBF(40),IDCB2(144),LBUF(144) 
      DIMENSION INFO1(12),INFO2(10) 
      DIMENSION NAM2(3),INAME(3)
      DIMENSION INAM3(10),INAM4(10),INAM5(10) 
      DIMENSION IMG10(5),IONE(6),MERR(5)
      COMMON/MERG1/ IQUIT,ILU(3),IDCB(272),INAM2(10),ITEMP,INAM1(10)
      COMMON/MERG2/ ISIZE(2),IRB,IOFF,JSEC,IDCB1(144),RECNT 
C 
      EQUIVALENCE (NAM2,INAM2)
      EQUIVALENCE (ICRF,INAM1(6)),(ISECF,INAM1(5))
      EQUIVALENCE (ISECU,INAM2(5)),(ICR,INAM2(6)) 
C 
      DATA INFO1/2HEN,2HTE,2HR ,2HDE,2HST,2HIN,2HAT,2HIO, 
     &           2HN ,2HNA,2HMR,20137B/ 
      DATA INFO2/2HEN,2HTE,2HR ,2HCO,2HMM,2HAN,2HD ,2HNA,2HMR,20137B/ 
      DATA IONE/6412B,2HME,2HRG,2HE ,2HST,2HOP/ 
      DATA IMG10/6412B,2HME,2HRG,2H 0,2H01/ 
      DATA MERR/6412B,2HFM,2HGR,2H- ,2H  /
      DATA MERG/6412B,2HME,2HRG,2H 0,2H02/
C 
C 
C 
C 
C 
C 
C     GET THE COMMAND STRING (RU,MERGE,NAMR1,NAMR2) 
C 
      CALL EXEC(14,1,INBF,-80)
      CALL ABREG(IA,IB) 
C 
C 
      IS=1
      ILU=LOGLU(ISES)+400B
C 
      IQUIT=0 
      NOTRUN=0
      ITEMP=0 
C 
C     SET RECORD COUNT TO ZERO
C     CLEAR OUT BUFFERS 
C 
      RECNT=0 
      DO 23 I=1,10
23    INAM2(I)=0
      INAM1(I)=0
      CONTINUE
C     PICK UP "RU" AND "MERGE"
      IF(NAMR(INAM1,INBF,IB,IS))10,10 
10    IF(NAMR(INAM1,INBF,IB,IS))20,20 
C 
C     PARSE THE FIRST AND SECOND PARAMETERS 
C     IF THEY EXIST 
C 
20    IF(NAMR(INAM1,INBF,IB,IS))35,30 
30    IF(NAMR(INAM2,INBF,IB,IS))222,999 
C 
C     IF THE FIRST PARM. DOESN'T EXIST CHECK FOR SECOND 
C 
35    IF(NAMR(INAM2,INBF,IB,IS))100,999 
C 
C     IF THE SECOND PARAMETER EXISTS AND THE FIRST DOES NOT THEN
C     GO INTO INTERACIVE MODE 
C 
C 
C     CHECK FOR PASSING OF AN LU I.E. IS PARAMETER > TWO ASCII BLANKS 
999   IF(INAM1.GT.2H  )GO TO 98 
C 
C     IF FIRST PARAMETER WASN'T SPECIFIED THEN DEFAULT TO TERMINAL
C 
      IF(INAM1.NE.0)GO TO 993 
      INAM1=LOGLU(ISES)+400B
      GO TO 955 
C 
C     CHECK FOR VALIDITY OF LU PASSED IN (NAMR1)
C 
993   IF((INAM1.LT.64).AND.(INAM1.GT.0))GO TO 954 
      GO TO 106 
C 
C     PREPARE FOR EXTENDED EXEC CALL
C 
954   INAM1=INAM1+400B
955   CALL EXEC(13+100000B,INAM1,ISTAT) 
      GO TO 106 
958   ICHEK=IAND(ISTAT,37400B)/256
C 
C     CAN'T BE A DISC LU
C 
      IF((ICHEK.LE.27B).OR.(ICHEK.GE.34B))GO TO 995 
      GO TO 106 
C 
C     CHECK WHETHER OR NOT FIRST PARM IS INTERACTIVE DEVIEC 
C 
995   INT=IFTTY(INAM1)
      IF(INT.EQ.-1)GO TO 190
C 
C     IF NOT INTERACTIVE THEN GO OPEN ANSWER FILE 
C 
98    CALL OPIN 
      GO TO 194 
C 
C 
C     METHOD I IS REQUESTED 
C     SET USER'S TERMINAL AS INTERACTIVE DEVICE 
C 
100   ILU=LOGLU(ISES)+400B
C 
C     PROMPT FOR INFORMATION (FILENAMES ETC.) 
C 
C     ENTER DESTINATION NAMR
C 
      CALL REIO(2,ILU,INFO1,12) 
102   CALL REIO(1,ILU,INBF,-80) 
      CALL ABREG(IA,IB) 
      IF(INBF.EQ.2H/E)GO TO 200 
      IS=1
      IF(NAMR(INAM2,INBF,IB,IS))222,103 
C 
C     USER MUST SUPPLY DESTINATION PARAMETER
C 
103   IF(INAM2.EQ.0)GO TO 222 
C 
C     ENTER COMMAND NAMR
C 
      CALL REIO(2,ILU,INFO2,10) 
      CALL REIO(1,ILU,INBF,-80) 
      CALL ABREG(IA,IB) 
      IF(INBF.EQ.2H/E)GO TO 200 
      IS=1
      IF(NAMR(INAM1,INBF,IB,IS))222,888 
6     ILU=LOGLU(ISES)+400B
C 
C     USER MUST SUPPLY COMMAND INPUT PARAMETER
C 
888   IF (INAM1.EQ.0)GO TO 222
C 
C     CHECK TO SEE IF NAMR1 IS A LOGICAL UNIT 
C 
      IF(INAM1.GT.2H  )GO TO 887
C 
C     IF IT'S AN LU THEN CHECK LEGALITY 
C 
      IF((INAM1.LT.64).AND.(INAM1.GT.0))GO TO 885 
C 
C     IF NOT THEN RETURN ERROR OF ILLEGAL LU
C 
      GO TO 106 
C 
C     PREPARE FOR EXTENED EXEC CALL 
C 
885   CALL EXEC(13+100000B,INAM1,ISTAT) 
      GO TO 106 
886   ICHEK=IAND(ISTAT,37400B)/256
      IF((ICHEK.LE.27B).OR.(ICHEK.GE.34B))GO TO 883 
      GO TO 106 
C 
C     CHECK NAMR1 FOR INTERACTIVE DEVICE
C 
883   INT=IFTTY(INAM1)
      IF(INT.NE.-1)GO TO 887
      INAM1=INAM1+400B
      GO TO 190 
C 
C     IF NOT INTERACTIVE THEN GO OPEN ANSWER FILE 
C 
887   CALL OPIN 
      GO TO 194 
C 
C     ON RETURN FROM OPEN GO CLOSE FILES
C 
C 
106   CALL EXEC(2,ILU,MERG,5) 
      CALL PTERR(MERG(2),IERR)
      GO TO 200 
C 
222   CALL EXEC(2,ILU,IMG10,6)
      CALL PTERR(IMG10(2),IERR) 
      GO TO 200 
444   IERR=-IERR
      CALL CNUMD(IERR,MERR(3))
      MERR(3)=2HGR
      MERR(4)=IOR(MERR(4),26460B) 
      MERR(5)=IOR(MERR(5),30060B) 
      CALL EXEC(2,ILU,MERR,5) 
C 
C     PUT ERROR CODE IN SESSION CONTROL BLOCK 
C 
      CALL PTERR(MERR(2),IERR)
      GO TO 200 
190   ILU=INAM1 
C 
C     INPUT WILL BE SUPPLIED INTERACTIVELY CALL OPIN1 
C 
      CALL OPIN1
C 
C     IF SIZE IS -1 THEN DO A CLOSE WITH TRUNCATE 
C     OTHERWISE DONT'T TRUNCATE DESTINATION FILE
C 
194   IF(ISIZE.NE.-1)GO TO 195
      CALL LOCF(IDCB,IERR,I,IRB,I,JSEC) 
      ITRUN=JSEC/2-IRB-1
C 
C     WRITE END OF FILE 
C 
195   CALL WRITF(IDCB,IERR,IXX,-1)
      CALL CLOSE(IDCB,IERR,ITRUN) 
      CALL CLOSE(IDCB1,IERR)
      CALL CLOSE(IDCB2,IERR)
200   ITEMP=0 
C 
C     PRINT MERGE STOP
C 
      CALL EXEC(2,ILU,IONE,6) 
      GO TO 90
90    END 
C 
C 
      BLOCK DATA GLOBL
      COMMON/MERG1/ IQUIT,ILU(3),IDCB(272),INAM2(10),ITEMP,INAM1(10)
      COMMON/MERG2/ ISIZE(2),IRB,IOFF,JSEC,IDCB1(144),RECNT 
      END 
C 
C 
C     THE OPIN SUBROUTINE OPENS THE COMMAND FILE SUPPLIED BY THE USER.
C     IT THEN READS A FILE NAME, OPEN THAT FILE AND CALLS APPND TO READ 
C     FROM THAT FILE AND WRITE INTO THE DESTINATION NAMR. 
C     AFTER NO MORE FILES NAMES ARE READ CONTROL IS RETURN TO THE MAIN. 
C 
C 
      SUBROUTINE OPIN 
      LOGICAL NAMR
      DIMENSION INAMT(2),MERG(5)
      DIMENSION MERR(5) 
      DIMENSION INAM5(10),INBF(40),IDCB2(144) 
      COMMON/MERG1/ IQUIT,ILU(3),IDCB(272),INAM2(10),ITEMP,INAM1(10)
      COMMON/MERG2/ ISIZE(2),IRB,IOFF,JSEC,IDCB1(144),RECNT 
      EQUIVALENCE (ISECE,INAM5(5)),(ICRE,INAM5(6)),(ICRF,INAM1(6))
      EQUIVALENCE (ISECU,INAM2(5)),(ICR,INAM2(6)),(ISECF,INAM1(5))
      DATA MERR/6412B,2HFM,2HGR,2H- ,2H  /
      DATA MERG/6412B,2HME,2HRG,2H 0,2H02/
30    ITMP=0
C 
C     CHECK TO SEE IF NAMR2 IS AN LU
C 
      IF(INAM2.GT.2H  )GO TO 38 
      CALL EXEC(13+100000B,INAM2,ISTAT) 
      GO TO 106 
34    ICHEK=IAND(ISTAT,37400B)/256
C 
C     NAMR2 CAN'T BE A DISC DEVICE
C 
      IF((ICHEK.LE.27B).OR.(ICHEK.GE.34B))GO TO 38
      IQUIT=-1
      GO TO 106 
C 
C     OPEN UP NAMR1 
C 
38    CALL OPENF(IDCB1,IERR,INAM1,IOP,ISECF,ICRF) 
      IF(IERR.GE.0)GO TO 40 
C 
C     RETURN ERROR IF IT EXISTS 
C 
      IERR=-IERR
      CALL CNUMD(IERR,MERR(3))
      MERR(3)=2HGR
      MERR(4)=IOR(MERR(4),26460B) 
      MERR(5)=IOR(MERR(5),30060B) 
      CALL EXEC(2,ILU,MERR,5) 
      CALL PTERR(MERR(2),IERR)
      ITEMP=1 
      IQUIT=-1
      GO TO 70
C 
C     BEFORE READING FILE NAME CHECK BREAK FLAG STATUS
C 
40    IF(IFBRK(IDMY))70,50
C 
C     KEEP COUNT OF FILE NAMES READ 
C 
50    ITMP=ITMP+1 
C 
C     NOW READ IN FILE NAME 
C 
53    CALL READF(IDCB1,IERR,INBF,40,LEN)
      IF(LEN.GE.0)GO TO 55
C 
C     IF NO MORE FILE NAMES THEN CLOSE COMMAND FILE 
C 
      CALL CLOSE(IDCB1,IERR)
      GO TO 70
55    IF(IERR.NE.0)GO TO 62 
      IS=1
      IB=2*LEN
C 
C     PARSE FILE NAME 
C 
      IF(NAMR(INAM5,INBF,IB,IS))70,65 
C 
C     CHECK TO SEE IF PARAMETER IS NULL 
C 
65    IF((INAM5.EQ.0).AND.(INAM5(4).EQ.0))GO TO 53
C 
C     REMEMBER CURRENT POSITION IN DESTINATION FILE 
C 
      CALL LOCF(IDCB,IERR,RECNT,IRB,IOFF,JSEC)
C 
C     WRITE OUT FILENAME TO TERMINAL
C 
      CALL EXEC(2,ILU,INBF,LEN) 
C 
C     OPEN FILE TO BE CONCATENATED
C 
      CALL OPENF(IDCB2,IERR,INAM5,IOP,ISECE,ICRE) 
      IF(IERR.GE.0)GO TO 64 
62    IERR=-IERR
      CALL CNUMD(IERR,MERR(3))
      MERR(3)=2HGR
      MERR(4)=IOR(MERR(4),26460B) 
      MERR(5)=IOR(MERR(5),30060B) 
      CALL EXEC(2,ILU,MERR,5) 
      CALL PTERR(MERR(2),JERR)
C 
C     IF FILE CAN'T BE FOUND THEN REPORT
C     ERROR AND READ ANOTHER NAME.
C 
      IF(IERR.NE.6)GO TO 70 
      ITMP=ITMP-1 
      GO TO 40
64    RECNT=0 
      IF(ITMP.EQ.1)GO TO 66 
      CALL WRITF(IDCB,IERR,ILBUF,0) 
C 
      GO TO 68
66    IF(INAM2.GT.2H  )GO TO 995
C 
C     IF NAMR2 IS A FILE NAME THEN TRY TO CREATE FILE 
C     IF CREATION NOT POSSIBLE (FMGR-002) THEN OPEN FILE
C     OTHERWISE NAMR2 IS AN LU, CALL OPENF TO OPEN LU 
C 
234   CALL OPENF(IDCB,IERR,INAM2,0,0,0) 
      IF(IERR.GE.0)GO TO 68 
      CALL CLOSE(IDCB1,IERR)
      CALL CLOSE(IDCB2,IERR)
      IQUIT=-1
      GO TO 68
C 
C     PREPARE TO CREATE DESTINATION FILE
C     TYPE IS DEFAULTED TO TYPE OF FIRST FILE IN COMMAND FILE 
C     SIZE IS DEFAULTED TO -1 
C     IF FILE ALREADY EXISTS THEN OPEN IT 
C 
995   ITYPE=IERR
      IF(INAM2(7).NE.0)ITYPE=INAM2(7) 
      ISIZE=-1
      IF(INAM2(8).NE.0)ISIZE=INAM2(8) 
      IF(INAM2(8).NE.-1)NOTRUN=1
      CALL CREAT(IDCB,IERR,INAM2,ISIZE,ITYPE,ISECU,ICR,256) 
C 
C     IF FILE ALREADY EXISTS THEN OPEN IT 
C 
      IF(IERR.EQ.-2)GO TO 999 
      IF(IERR.GE.0)GO TO 68 
      JERR=IERR 
      CALL CLOSE(IDCB1,IERR)
      CALL CLOSE(IDCB2,IERR)
      IQUIT=-1
      IERR=JERR 
      GO TO 62
C 
C     FILE ALREADY EXISTS OPEN IT 
C 
999   CALL OPENF(IDCB,IERR,INAM2,IOP,ISECU,ICR) 
      IF(IERR.GE.0)GO TO 68 
      CALL CLOSE(IDCB1,IERR)
      CALL CLOSE(IDCB2,IERR)
      IQUIT=-1
      GO TO 62
C 
C     DESTINATION NAMR IS SET UP CALL APPND TO
C     READ FROM SOURCE FILE AND WRITE INTO DESTINATION FILE 
C 
68    CALL APPND(IDCB2,ITYPE) 
C 
C     IF NO ERROR IN APPND THEN TRY TO READ ANOTHER FILE NAME 
C 
      IF(IQUIT.EQ.-1)GO TO 70 
      GO TO 40
C 
106   CALL EXEC(2,ILU,MERG,5) 
      CALL PTERR(MERG(2),IERR)
C 
70    RETURN
      END 
C 
C     THE OPIN1 SUBROUTINE IS THE INTERACTIVE HANDLER OF
C     LIBRARIAN.  IT PROMPTS THE USER WITH THE
C     "ENTER NAMR" COMMAND. 
C     IT OPENS THE SOURCE FILE AND CREATES OR OPENS THE 
C     DESTINATION NAMR.  WHEN NO MORE FILES ARE SUPPLIED
C     (ENTERING /E) THEN CONTROL IS RETURNED TO THE MAIN. 
C 
C 
      SUBROUTINE OPIN1
      LOGICAL NAMR
      DIMENSION MERR(5),INAMT(2),MERG(5)
      DIMENSION IDCB2(144),INBF(40),INFO4(7)
      COMMON/MERG1/ IQUIT,ILU(3),IDCB(272),INAM2(10),ITEMP,INAM1(10)
      COMMON/MERG2/ ISIZE(2),IRB,IOFF,JSEC,IDCB1(144),RECNT 
      EQUIVALENCE (ICRF,INAM1(6)),(ISECF,INAM1(5))
      EQUIVALENCE (ICR,INAM2(6)),(ISECU,INAM2(5)) 
      DATA INFO4/2HEN,2HTE,2HR ,2HNA,2HMR,2H  ,20137B/
      DATA MERR/6412B,2HFM,2HGR,2H- ,2H  /
      DATA MERG/6412B,2HME,2HRG,2H 0,2H01/
C     OPEN FILE TO BE TRANSFERRED 
      ITMP=0
      GO TO 7 
C 
C     ON THE FIRST TIME INTO THIS SUBROUTINE GO PROMPT FOR
C     SOURCE NAMR 
C 
5     ITMP=ITMP+1 
      IF((INAM1.EQ.0).AND.(INAM1(4).EQ.0))GO TO 690 
      CALL OPENF(IDCB2,IERR,INAM1,IOP,ISECF,ICRF) 
C 
C     OTHERWISE OPEN NAMR1
C 
      IF(IERR.GE.0)GO TO 6
444   IERR=-IERR
      CALL CNUMD(IERR,MERR(3))
      MERR(3)=2HGR
      MERR(4)=IOR(MERR(4),26460B) 
      MERR(5)=IOR(MERR(5),30060B) 
      CALL EXEC(2,ILU,MERR,5) 
      CALL PTERR(MERR(2),JERR)
C 
C     IF FILE CAN'T BE FOUND THEN REPORT
C     ERROR AND GET ANOTHER FILE NAME 
C 
      IF(IERR.NE.6)GO TO 8
      ITMP=ITMP-1 
      GO TO 690 
434   IQUIT=-1
      GO TO 8 
C 
C     KEEP COUNT OF NUMBER OF FILES OPENED
C 
6     ITYPE=IERR
      CALL LOCF(IDCB,IERR,RECNT,IRB,IOFF,JSEC)
      IF(ITMP.NE.1)GO TO 600
C 
C     CHECK TO SEE IF NAMR2 IS AN LU
C 
      IF(INAM2.GT.2H  )GO TO 995
C 
C     CHECK LU AGAINST DISC DRIVER
C 
C     CHECK LU AGAINST DISC DRIVER
      CALL EXEC(13+100000B,INAM2,ISTAT) 
      GO TO 106 
233   ICHEK=IAND(ISTAT,37400B)/256
C 
C     LU CAN`T HAVE DRIVERS 30,31,32,33 
C 
      IF((ICHEK.LE.27B).OR.(ICHEK.GE.34B))GO TO 234 
      GO TO 106 
C 
C     IT IS AN LU OPEN IT 
C 
234   CALL OPENF(IDCB,IERR,INAM2,0,0,0) 
      IF(IERR.GE.0)GO TO 610
      IERR=-IERR
      CALL CNUMD(IERR,MERR(3))
      MERR(3)=2HGR
      MERR(4)=IOR(MERR(4),26460B) 
      MERR(5)=IOR(MERR(5),30060B) 
      CALL EXEC(2,ILU,MERR,5) 
      CALL PTERR(MERR(2),IERR)
      CALL CLOSE(IDCB2,IERR)
      IQUIT=-1
      GO TO 8 
C 
C     NAMR2 IS A FILE NAME. TRY TO CREATE IT
C     DEFAULT TYPE TO TYPE OF FIRST SOURCE FILE 
C     DEFAULT SIZE TO -1
C 
995   IF(INAM2(7).NE.0)ITYPE=INAM2(7) 
      ISIZE=-1
      IF(INAM2(8).NE.0)ISIZE=INAM2(8) 
      IF(INAM2(8).NE.-1)NOTRUN=1
      CALL CREAT(IDCB,IERR,INAM2,ISIZE,ITYPE,ISECU,ICR,256) 
C 
C     IF FILE ALREADY EXISTS THEN OPEN IT 
C 
      IF(IERR.EQ.-2)GO TO 99
      IF(IERR.GE.0)GO TO 610
      IERR=-IERR
      CALL CNUMD(IERR,MERR(3))
      MERR(3)=2HGR
      MERR(4)=IOR(MERR(4),26460B) 
      MERR(5)=IOR(MERR(5),30060B) 
      CALL EXEC(2,ILU,MERR,5) 
      CALL PTERR(MERR(2),IERR)
      CALL CLOSE(IDCB2,IERR)
      IQUIT=-1
      GO TO 8 
C 
C     FILE ALREADY EXISTS SO OPEN IT
C 
99    CALL OPENF(IDCB,IERR,INAM2,IOP,ISECU,ICR) 
      IF(IERR.GE.O)GO TO 610
      IERR=-IERR
      CALL CNUMD(IERR,MERR(3))
      MERR(3)=2HGR
      MERR(4)=IOR(MERR(4),26460B) 
      MERR(5)=IOR(MERR(5),30060B) 
      CALL EXEC(2,ILU,MERR,5) 
      CALL PTERR(MERR(2),IERR)
      CALL CLOSE(IDCB2,IERR)
      IQUIT=-1
      GO TO 8 
C 
C     WRITE ZERO LENGTH RECORD IN BETWEEN FILES 
C 
600   CALL WRITF(IDCB,IERR,ILBUF,0) 
C 
C     CALL APPND TO CONCATENATE FILES INTO THE DESTINATION NAMR 
C 
610   CALL APPND(IDCB2,ITYPE) 
      IF(IQUIT.EQ.-1)GO TO 8
C 
C     CLEAR OUT BUFFER
C 
690   DO 700 I=1,10 
700   INAM1(I)=2H 
      CONTINUE
7     CALL REIO(2,ILU,INFO4,7)
      CALL REIO(1,ILU,INBF,-80) 
      CALL ABREG(IA,IB) 
      IF(INBF.EQ.2H/E)GO TO 8 
      IS=1
C 
C     IF ANOTHER FILE NAME IS SUPPLIED THEN GO OPEN FILE
C     OTHERWISE QUIT
C 
      IF(NAMR(INAM1,INBF,IB,IS))8,5 
C 
106   CALL EXEC(2,ILU,MERG,5) 
      CALL PTERR(MERG(2),IERR)
C 
8     RETURN
      END 
C 
C     THE APPND SUBROUTINE READS FROM THE SOURCE NAMR 
C     AND WRITES INTO THE DESTINATION NMAR. 
C 
C 
      SUBROUTINE APPND(IDCB2,ITYPE) 
      DIMENSION LBUF(257),IDCB2(144),MERR(5)
      COMMON/MERG1/ IQUIT,ILU(3),IDCB(272),INAM2(10),ITEMP,INAM1(10)
      COMMON/MERG2/ ISIZE(2),IRB,IOFF,JSEC,IDCB1(144),RECNT 
      DATA MERR/6412B,2HFM,2HGR,2H- ,2H  /
C 
C     READ FROM THE SOURCE NAMR 
C 
      IL=257
      IF(ITYPE.EQ.1)IL=128
20    CALL READF(IDCB2,IERR,LBUF,IL,LEN)
      IF(LEN.EQ.-1)GO TO 41 
      IF(IERR.EQ.-12)GO TO 41 
      IF(IERR.EQ.0)GO TO 44 
      IERR=-IERR
      IQUIT=-1
      CALL CNUMD(IERR,MERR(3))
      MERR(3)=2HGR
      MERR(4)=IOR(MERR(4),26460B) 
      MERR(5)=IOR(MERR(5),30060B) 
      CALL EXEC(2,ILU,MERR,5) 
      CALL PTERR(MERR(2),IERR)
      GO TO 49
41    CALL CLOSE(IDCB2,IERR)
      GO TO 49
44    IF(LEN.NE.0)GO TO 445 
C 
C     WRITE ZERO LENGTH RECORD
C 
      CALL WRITF(IDCB,IERR,ILBUF,0) 
      GO TO 20
C 
C     NOW WRITE INTO THE DESTINATION NAMR 
C 
445   IF(ITYPE.EQ.1)LEN=128 
      CALL WRITF(IDCB,IERR,LBUF,LEN)
      IF(IERR.EQ.0)GO TO 20 
      IF(IERR.NE.-7)GO TO 446 
      IQUIT=-1
      GO TO 450 
C 
C     IF NO MORE ROOM OCCURS(FMGR-033) THEN 
C     GET POSITION OF DESTINATION NAMR BEFORE 
C     LAST FILE WAS CONCATENATED AND WRITE END OF 
C     FILE AND THEN CLOSE WITH TRUNCATE.  ISSUE A 
C     MESSAGE DESCRIBING WHAT HAPPENED. 
C 
446   IF(IERR.NE.-33)GO TO 450
      IERR=-IERR
      CALL CNUMD(IERR,MERR(3))
      CALL APOSN(IDCB,IERR,RECNT,IRB,IOFF)
      CALL WRITF(IDCB,IERR,IXX,-1)
      ITRUN=JSEC/2-IRB-1
      CALL CLOSE(IDCB,IERR,ITRUN) 
      MERR(3)=2HGR
      MERR(4)=IOR(MERR(4),26460B) 
      MERR(5)=IOR(MERR(5),30060B) 
      CALL EXEC(2,ILU,MERR,5) 
      CALL PTERR(MERR(2),IERR)
      CALL EXEC(2,ILU,26HNO MORE ROOM ON CARTRIDGE ,13) 
      CALL EXEC(2,ILU,40HFILE CONCATENATION WAS SUCCESSFUL UP TO ,20) 
      CALL EXEC(2,ILU,36HBUT NOT INCLUDING THE LAST FILE READ,18) 
      IQUIT=-1
      GO TO 49
450   IERR=-IERR
      CALL CNUMD(IERR,MERR(3))
      MERR(3)=2HGR
      MERR(4)=IOR(MERR(4),26460B) 
      MERR(5)=IOR(MERR(5),30060B) 
      CALL EXEC(2,ILU,MERR,5) 
      CALL PTERR(MERR(2),IERR)
C 
C     RETURN TO CALLING PROGRAM 
C 
49    RETURN
      END