FTN4
C 
C    VERSION   8 / 13 / 77   SL 
C 
      PROGRAM SAFD
C 
C 
C*************************************************************
C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977.  ALL RIGHTS    *
C RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
C*************************************************************
C 
C 
C 
C 
C 
C 
C************************************************************** 
C       SOURCE (&MSAFD)  PART NUMBER = 92064-18232            * 
C       RELOCATABLE (%MSAFD) PART NUMBER = 92064-16086        * 
C       DATE = 1740                                           * 
C************************************************************** 
C 
C 
C 
C 
C 
C 
      DIMENSION LU(5),IREG(2),IHEDD(33) 
      DIMENSION IBUF(3840),IBF(3712)
      INTEGER FIRST,LAST
C 
CCCCCCCCCCCC
      DIMENSION MEST(31),IHEAD(33),IH2(30),IH22(30) 
CCCCCCCCCCCCC 
      DIMENSION MESS1(18),MESS2(14),MESS3(17),MESS4(21) 
      DIMENSION MESS7(11),IPBUF(33),MESS19(16)
      DIMENSION MESS8(2),MESS9(11),MESS10(22),MESS11(22)
      DIMENSION MESS13(18),MESS14(6),MESS17(15),MESS18(12)
      DIMENSION MESS20(6),MESS15(22),MESS12(15),MESS16(15)
C 
CCCCCCCCCCCCCC
      EQUIVALENCE (ITPE,IHEAD),(ITRAK,IHEAD(2)) 
      EQUIVALENCE (ISEC,IHEAD(3)),(IH2,IHEAD(4))
      EQUIVALENCE (IH22,IHEDD(4)) 
CCCCCCCCCCCCCCC 
      EQUIVALENCE (IA,IREG),(IB,IREG(2)),(X,IREG) 
C 
C 
CCCCCCC 
      DATA MEST/2HEN,2HD ,2HOF,2H C,2HAR,2HTR,2HID,2HGE,2H O,2HR ,
     &          2HMA,2HG ,2HTA,2HPE,2H R,2HEA,2HCH,2HED,2H. ,2HIN,
     &          2HSE,2HRT,2H N,2HEW,2H T,2HAP,2HE ,2H(#,2H  ,2H  ,
     &          2H)./ 
      DATA MESS1/6412B,2HEN,2HTE,2HR ,2HCA,2HRT,2HRI,2HDG,2HE ,2HOR,
     &          2H M,2HAG,2H T,2HAP,2HE ,2HLU,2H: ,2H _/
      DATA MESS2/6412B,2HEN,2HTE,2HR ,2HFL,2HEX,2HIB,2HLE,2H D,2HIS,
     &            2HC ,2HLU,2H: ,2H _/
      DATA MESS3/6412B,2HER,2HRO,2HR ,2H- ,2HNO,2HT ,2HA ,2HFL,2HEX,
     &            2HIB,2HLE,2H D,2HIS,2HC ,2HLU,2H? / 
      DATA MESS4/6412B,2HER,2HRO,2HR ,2H- ,2HNO,2HT ,2HA ,2HCA,2HRT,
     &          2HRI,2HDG,2HE ,2HOR,2H M,2HAG,2H T,2HAP,2HE ,2HLU,
     &          2H? / 
      DATA MESS7/6412B,2HEN,2HTE,2HR ,2HTA,2HPE,2H H,2HEA,2HDE,2HR:,
     &            2H _/ 
      DATA MESS8/2HST,2HOP/ 
      DATA MESS9/6412B,2HFI,2HLE,2HS ,2HSA,2HVE,2HD ,2HON,2H T,2HAP,
     &            2HE / 
      DATA MESS10/2HFL,2HEX,2HIB,2HLE,2H D,2HIS,2HC ,2HSA,2HVE,2H O,
     &            2HR ,2HRE,2HST,2HOR,2HE?,2H (,2HSA,2H,R,2HE,,2HNO,
     &            2H):,2H _/
      DATA MESS11/2HER,2HRO,2HR ,2H- ,2HNO,2HT ,2HEN,2HOU,2HGH,2H T,
     &            2HRA,2HCK,2HS ,2HON,2H F,2HLE,2HXI,2HBL,2HE ,2HDI,
     &            2HSC,2H? /
      DATA MESS12/2HEN,2HTE,2HR ,2HMA,2HG ,2HTA,2HPE,2H F,2HIL,2HE ,
     &            2HNU,2HMB,2HER,2H: ,2H _/ 
      DATA MESS13/6412B,2HFI,2HLE,2HS ,2HRE,2HST,2HOR,2HED,2H O,2HN , 
     &            2HFL,2HEX,2HIB,2HLE,2H D,2HIS,2HC.,6412B/ 
      DATA MESS14/6412B,2HHE,2HAD,2HER,2H I,2HS:/ 
      DATA MESS15/2HER,2HRO,2HR ,2H- ,2HWR,2HON,2HG ,2HTA,2HPE,2H. ,
     &          2HIN,2HSE,2HRT,2H N,2HEW,2H T,2HAP,2HE ,2H(#,2H  ,
     &          2H  ,2H)./
      DATA MESS16/2HER,2HRO,2HR ,2H- ,2HNO,2HT ,2HA ,2HPO,2HSI,2HTI,
     &            2HVE,2H N,2HUM,2HBE,2HR?/ 
      DATA MESS17/2HER,2HRO,2HR ,2H- ,2HEO,2HT ,2H- ,2HFI,2HLE,2H N,
     &             2HOT,2H F,2HOU,2HND,2H? /
      DATA MESS18/6412B,2HTE,2HRM,2HIN,2HAT,2HE ,2H(Y,2HES,2H,N,2HO), 
     &            2H: ,2H _/
      DATA MESS19/2HTO,2H C,2HON,2HTI,2HNU,2HE ,2HHI,2HT ,2HAN,2HY ,
     &            2HKE,2HY/,2HRE,2HTU,2HRN,2H _/
      DATA MESS20/6412B,2HTA,2HPE,2H #,2H  ,2H  / 
C 
      CALL RMPAR(LU)
      IF(LU)1,2,32
1     STOP
2     LU=1
32    IF(LU.LE.63)33,1
33    ILU=LU+400B 
C 
CCCCCCCCCCCCCCCCCCCC
      JLNTH=3840
CCCCCCCCCCCCCCCCCCCC
C   GET SAVE OR RESTORE 
C 
5     CALL REIO(2,ILU,MESS10,22)
      X=REIO(1,ILU,IBUF,10) 
      IF(IBUF(1).EQ.2HSA)GO TO 15 
      IF(IBUF(1).NE.2HRE)GO TO 8000 
      GO TO 2000
C 
C  GET FLEXIBLE DISC LU 
15    CALL REIO(2,ILU,MESS2,14) 
      X=REIO(1,ILU,IBUF,10) 
      CALL PARSE(IBUF,IB*2,IPBUF) 
      IC=IPBUF(1) 
      IF(IC.NE.1)GO TO 18 
      IDISC=IPBUF(2)
      LASTTR=IPBUF(6) 
C 
16    CALL EXEC(13,IDISC,ISTAT) 
      ITYPE=IAND(ISTAT,37400B)/256
      IF(ITYPE.EQ.33B)GO TO 10
18    CALL REIO(2,ILU,MESS3,17) 
20    CALL REIO(2,ILU,MESS18,12)
      X=REIO(1,ILU,IBUF,2)
      IF(IBUF(1).EQ.2HNO)GO TO 15 
      IF(IBUF(1).NE.2HYE)GO TO 20 
      GO TO 8000
C 
C   GET CARTRIDGE OR MAG TAPE LU
C 
10    CALL REIO(2,ILU,MESS1,18) 
      X=REIO(1,ILU,IBUF,10) 
      CALL PARSE(IBUF,IB*2,IPBUF) 
      MTLU=IPBUF(2) 
      IC=IPBUF(1) 
      IF(IC.NE.1)GO TO 12 
C 
      CALL EXEC(13,MTLU,ISTAT,IX,ISUB)
      IF(IAND(ISTAT,37400B)*2.NE.5000B)GO TO 13 
      IF(IAND(ISUB,37B).EQ.1B)GO TO 14
      IF(IAND(ISUB,37B).EQ.2B)GO TO 14
12    CALL REIO(2,ILU,MESS4,21) 
22    CALL REIO(2,ILU,MESS18,12)
      X=REIO(1,ILU,IBUF,2)
      IF(IBUF(1).EQ.2HNO)GO TO 10 
      IF(IBUF(1).NE.2HYE)GO TO 22 
      GO TO 8000
13    IF(IAND(ISTAT,37400B).NE.11400B)GO TO 12
C 
C   FIND PLACE ON TAPE TO BEGIN THE SAVE
7     CALL REIO(2,ILU,MESS12,15)
      X=REIO(1,ILU,IBUF,-10)
      CALL PARSE(IBUF,IB,IPBUF) 
      IC=IPBUF(1) 
      INUM=IPBUF(2) 
      IF(INUM.LE.0)GO TO 4
      IF(IC.EQ.1)GO TO 6
4     CALL REIO(2,ILU,MESS16,15)
      GO TO 7 
6     X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 6 
8     IF(INUM.EQ.1)GO TO 14 
      REWIND MTLU 
19    X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 19
      DO 9 I=2,INUM 
      X=EXEC(3,MTLU+1300B)
3     X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 3 
      ISTAT=IAND(IA,40B)
      IF(ISTAT.EQ.0)GO TO 9 
      CALL REIO(2,ILU,MESS17,15)
      GO TO 7 
9     CONTINUE
      GO TO 17
14    REWIND MTLU 
C 
17    X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 17
C 
30    DO 31 I=1,30
       IH2(I)=2H
31    CONTINUE
C 
      CALL REIO(2,ILU,MESS7,11) 
      CALL REIO(1,ILU,IH2 ,30)
C 
C 
C    HAVE ALL LU'S, NOW GO COPY THE DISC... 
C       COPY ALL DIRECTORY TRACKS FIRST, FOLLOWED BY
C       ALL TRACKS USED BY FMP  (UN-USED TRACKS WON'T BE COPIED)
C 
      X=EXEC(1,IDISC,IBUF,128,10000,0)
      ITRAK=IB-1
      IF(LASTTR.NE.0)ITRAK=LASTTR 
      CALL EXEC(1,IDISC,IBUF,JLNTH,ITRAK,0) 
      FIRST=IBUF(5) 
      LAST=IBUF(10) 
      IF(LAST.EQ.LASTTR)LAST=LAST-1 
      LOWDIR=IBUF(8)
C 
C  WRITE TAPE HEADER
C 
CCCCCCCCCCCCCCCCCC
      ITPE=1
      ISEC=0
      CALL EXEC(2,MTLU+100B,IHEAD,33) 
CCCCCCCCCCCCCCCCCC
C 
C  GO WRITE TRACK TO TAPE 
C 
      ASSIGN 42 TO JJ 
C 
      GO TO 1000
C 
C   READ A TRACK
C 
40    CALL EXEC(1,IDISC,IBUF,JLNTH,ITRAK,0) 
C 
C 
C  GO WRITE THE TRACK TO TAPE 
C 
      GO TO 1000
42    IF(ITRAK.EQ.LOWDIR)GO TO 45 
      ITRAK=ITRAK-1 
      GO TO 40
C 
45    ASSIGN 49 TO JJ 
      DO 49 ITRAK=FIRST,LAST
       CALL EXEC(1,IDISC,IBUF,JLNTH,ITRAK,0)
      GO TO 1000
49    CONTINUE
C 
      GO TO 90
C 
C   THIS ROUTINE RETURNS TO JJ
C 
1000  ICOUN=1 
      DO 1500 ISEC=0,58,2 
C 
C 
C    THIS SECTION DOES A DYNAMIC STATUS CHECK ON THE CARTRIDGE
C    TAPE LOOKING FOR EOT CONDITION. IF FOUND, A MESSAGE IS ISSUED
C    TO INFORM THE OPERATOR, AND THE PROGRAM IS SUSPENDED.
C 
C 
1001  X= EXEC(3,MTLU+600B)
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)  GOTO 1001 
      ISTAT=IAND(IA,40B)
      IF (ISTAT.EQ.0) GO TO 1050
C 
C   WE MUST HAVE REACHED EOT
C 
C   TELL THE OPERATOR ABOUT IT
C 
      ITPE=ITPE+1 
      MEST(29)=KCVT(ITPE) 
      CALL EXEC(2,ILU,MEST,31)
      CALL EXEC(2,ILU,MESS19,16)
      CALL EXEC(1,ILU,IREG,2) 
C 
C  WRITE A HEADER ON THE NEW TAPE 
C 
C 
C 
      REWIND MTLU 
C 
1042  X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 1042
      CALL EXEC(2,MTLU+100B,IHEAD,33) 
C 
C 
C THIS SECTION TRANSFERS 1 TRACK FROM IBUF TO CARTRIDGE TAPE
C 128 WORDS AT A TIME.
C 
1050  X=EXEC(2,MTLU+100B,IBUF(ICOUN),128) 
      ICOUN=ICOUN+128 
C 
1500  CONTINUE
      GOTO JJ 
C 
C 
C 
C 
90    ENDFILE MTLU
      ENDFILE MTLU
C 
C  END:   REWIND TAPE 
C 
99     REWIND MTLU
      CALL REIO(2,ILU,MESS9,11) 
C 
      GO TO 5 
C 
C  RESTORE FLEXIBLE DISC
C 
C   ENTER FLEXIBLE DISC LU
C 
2000  CALL REIO(2,ILU,MESS2,14) 
      X=REIO(1,ILU,IBUF,10) 
      CALL PARSE(IBUF,IB*2,IPBUF) 
      IC=IPBUF(1) 
      IF(IC.NE.1)GO TO 2008 
      IDISC=IPBUF(2)
      LASTTR=IPBUF(6) 
C 
C  CHECK TO MAKE SURE ITS A FLEXIBLE DISC 
2005  CALL EXEC(13,IDISC,ISTAT) 
      ITYPE=IAND(ISTAT,37400B)/256
      IF(ITYPE.EQ.33B)GO TO 2004
2008  CALL REIO(2,ILU,MESS3,17) 
2021  CALL REIO(2,ILU,MESS18,12)
      X=REIO(1,ILU,IBUF,2)
      IF(IBUF(1).EQ.2HNO)GO TO 2000 
      IF(IBUF(1).NE.2HYE)GO TO 2021 
      GO TO 8000
C 
C 
C  GET CARTRIDGE OR MAG TAPE LU 
C 
2004  CALL REIO(2,ILU,MESS1,18) 
      X=REIO(1,ILU,IBUF,10) 
      CALL PARSE(IBUF,IB*2,IPBUF) 
      IC=IPBUF(1) 
      IF(IC.NE.1)GO TO 2001 
      MTLU=IPBUF(2) 
C 
C  CHECK TO MAKE SURE ITS A CARTRIDGE OR MAG TAPE 
5000  CALL EXEC(13,MTLU,ISTAT,IX,ISUB)
      IF(IAND(ISTAT,37400B)*2.NE.5000B)GO TO 2002 
C  CHECK FOR SUBCHANNEL (LEFT OR RIGHT CARTRIDGE) 
      IF(IAND(ISUB,37B).EQ.1B)GO TO 2003
      IF(IAND(ISUB,37B).EQ.2B)GO TO 2003
2001  CALL REIO(2,ILU,MESS4,21) 
2023  CALL REIO(2,ILU,MESS18,12)
      X=REIO(1,ILU,IBUF,2)
      IF(IBUF(1).EQ.2HNO)GO TO 2004 
      IF(IBUF(1).NE.2HYE)GO TO 2023 
      GO TO 8000
2002  IF(IAND(ISTAT,37400B).NE.11400B)GO TO 2001
C 
C  FIND PLACE ON TAPE TO BEGIN RESTORE
2012  CALL REIO(2,ILU,MESS12,15)
      X=REIO(1,ILU,IBUF,-10)
      CALL PARSE(IBUF,IB,IPBUF) 
      IC=IPBUF(1) 
      INUM=IPBUF(2) 
C 
      IF(INUM.LE.0)GO TO 1999 
      IF(IC.EQ.1)GO TO 2006 
1999  CALL REIO(2,ILU,MESS16,15)
      GO TO 2012
2006  X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 2006
2013  IF(INUM.EQ.1)GO TO 2003 
      REWIND MTLU 
2009  X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 2009
      DO 2014 I=2,INUM
      X=EXEC(3,MTLU+1300B)
4050  X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 4050
      ISTAT=IAND(IA,40B)
      IF(ISTAT.EQ.0)GO TO 2014
      CALL REIO(2,ILU,MESS17,15)
      GO TO 2012
2014  CONTINUE
      GO TO 2007
2003  REWIND MTLU 
C 
C ENTER FLEXIBLE DISC LU
2007  X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 2007
C 
C  INITIALIZE IHEAD TO ZERO 
2010  DO 2011 I=1,30
      IH2(I)=2H 
2011  CONTINUE
C 
C  READ THE FIRST TAPES HEADER AND PUT IN  IHEAD. 
4000  CALL EXEC(1,MTLU+100B,IHEAD,33) 
      CALL REIO(2,ILU,MESS14,6) 
      CALL REIO(2,ILU,IHEAD(4),30)
      MESS20(5)=KCVT(IHEAD(1))
      CALL REIO(2,ILU,MESS20,6) 
4005  CALL EXEC(2,ILU,MESS18,12)
      X=EXEC(1,ILU,IBUF,1)
      IF(IBUF(1).EQ.2HYE)GO TO 8000 
      IF(IBUF(1).NE.2HNO)GO TO 4005 
      IF(IHEAD.EQ.1)GO TO 2030
      ITPE=1
      SEC=0 
      MESS15(20)=KCVT(ITPE) 
      CALL REIO(2,ILU,MESS15,22)
      CALL EXEC(2,ILU,MESS19,16)
      CALL EXEC(1,ILU,IREG,2) 
C 
      REWIND MTLU 
4001  X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 4001
      GO TO 5000
C  PROMPT LAST TRACK ON VIRGIN DISC 
2030  X=EXEC(1,IDISC,IBUF,128,10000,0)
      ITRAK=IB-1
      IF(LASTTR.NE.0)ITRAK=LASTTR 
      DO 2015 I=1,3840,128
      CALL EXEC(1,MTLU+100B,IBUF(I),128)
2015  CONTINUE
C 
C IDIR GETS # OF DIRECTORY TRACKS 
C IVIR GETS AVAILABLE FMP TRACKS ON VIRGIN DISC 
C   LAST GETS AVAILABLE FMP TRACKS ON TAPE
C CHECK TO SEE IF DISC CAN HOLD FILES ON TAPE 
C 
      IDIR=IBUF(9)
      IVIR=ITRAK+IDIR 
      LAST=IBUF(10)-1 
      IF(IVIR.GE.LAST)GO TO 2020
      CALL EXEC(2,ILU,MESS11,22)
      GO TO 8000
C 
C LOWDIR GETS LOWEST DIRECTORY TRACK
C FIRST GETS FIRST AVAILABLE TRACK FOR FMP
2020  LOWDIR=IBUF(8)
      FIRST=IBUF(5) 
C 
      ASSIGN 2042 TO JJ 
      ASSIGN 2062 TO KK 
C 
      GO TO KK
C 
2040  DO 2041 I=1,3840,128
      CALL EXEC(1,MTLU+100B,IBUF(I),128)
C 
C  CHECK FOR END OF TAPE
C 
3000  X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 3000
      ISTAT=IAND(IA,40B)
      IF(ISTAT.EQ.0)GO TO 2041
      ITPE=ITPE+1 
3001  MEST(29)=KCVT(ITPE) 
      CALL EXEC(2,ILU,MEST,31)
      CALL EXEC(2,ILU,MESS19,16)
      CALL EXEC(1,ILU,IREG,2) 
C 
2098  REWIND MTLU 
2029  X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 2029
C 
      DO 3002 J=1,30
      IH22(J)=2H
3002  CONTINUE
C 
C PRINT OUT HEADER
      CALL EXEC(1,MTLU+100B,IHEDD,33) 
      CALL REIO(2,ILU,MESS14,6) 
      CALL REIO(2,ILU,IHEDD(4),30)
      MESS20(5)=KCVT(IHEDD(1))
      CALL EXEC(2,ILU,MESS20,6) 
C 
C  CHECK TO SEE IF HEADERS MATCH
      DO 3003 K=4,33
      IF(IHEDD(K).NE.IHEAD(K))GO TO 3004
3003  CONTINUE
C 
C  CHECK FOR THE RIGHT TAPE 
      IF(ITPE.EQ.IHEDD)GO TO 2039 
3004  MESS15(20)=KCVT(ITPE) 
      CALL REIO(2,ILU,MESS15,22)
      CALL EXEC(2,ILU,MESS19,16)
      CALL EXEC(1,ILU,IREG,2) 
      GO TO 2098
C 
2039  ITRAK=IHEDD(2)
      ISEC=IHEDD(3) 
2041  CONTINUE
      GO TO KK
C 
C DECREMENT THE TRACK NUMBER
2042  IF(ITRAK.EQ.LOWDIR)GO TO 2045 
      ITRAK=ITRAK-1 
      GO TO 2040
C 
C FROM FIRST TO LAST TRACK FILL UP BUFFER ONE TRACK AT A TIME.
2045  ASSIGN 2049 TO JJ 
      ASSIGN 2060 TO KK 
      DO 2049 ITRAK=FIRST,LAST
      DO 2048 I=1,3840,128
      CALL EXEC(1,MTLU+100B,IBUF(I),128)
C 
C  CHECK FOR END OF TAPE
2047  X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 2047
      ISTAT=IAND(IA,40B)
      IF(ISTAT.EQ.0)GO TO 2048
      ITPE=ITPE+1 
2051  MEST(29)=KCVT(ITPE) 
      CALL EXEC(2,ILU,MEST,31)
      CALL EXEC(2,ILU,MESS19,16)
      CALL EXEC(1,ILU,IREG,2) 
C 
2052  REWIND MTLU 
2056  X=EXEC(3,MTLU+600B) 
      ISTAT=IAND(IA,1)
      IF(ISTAT.EQ.1)GO TO 2056
C 
      DO 2053 J=1,30
      IH22(J)=2H
2053  CONTINUE
C 
C  PRINT OUT HEADER 
      CALL EXEC(1,MTLU+100B,IHEDD,33) 
      CALL REIO(2,ILU,MESS14,6) 
      CALL REIO(2,ILU,IHEDD(4),30)
      MESS20(5)=KCVT(IHEDD(1))
      CALL EXEC(2,ILU,MESS20,6) 
C 
C  CHECK TO SEE IF HEADERS MATCH
      DO 2054 K=4,33
      IF(IHEDD(K).NE.IHEAD(K))GO TO 2055
2054  CONTINUE
C 
C  CHECK TO SEE IF RIGHT TAPE 
      IF(ITPE.EQ.IHEDD)GO TO 2048 
2055  MESS15(20)=KCVT(ITPE) 
      CALL REIO(2,ILU,MESS15,22)
      CALL EXEC(2,ILU,MESS19,16)
      CALL EXEC(1,ILU,IREG,2) 
C 
      GO TO 2052
2048  CONTINUE
      GO TO KK
2049  CONTINUE
      GO TO 2099
C 
C ELIMINATE THE FIRST SECTOR IN THE FIRST TRACK 
2060  K=1 
      DO 2061 J=129,3840
      IBF(K)=IBUF(J)
      K=K+1 
2061  CONTINUE
C 
C WRITE ONTO DISC 
      CALL EXEC(2,IDISC,IBF,3712,ITRAK,2) 
      ASSIGN 2062 TO KK 
      GO TO JJ
C 
2062  CALL EXEC(2,IDISC,IBUF,JLNTH,ITRAK,0) 
      GO TO JJ
C 
C 
2099  REWIND MTLU 
C 
C FILES RESTORED TO FLEXIBLE DISC 
      CALL REIO(2,ILU,MESS13,18)
      GO TO 5 
8000  CALL EXEC(2,ILU,MESS8,2)
      END 
      END$