FTN4,Q,C
      PROGRAM START (3,99),92425-16047 REV.2001 791127
C     NAME:START
C   SOURCE: 92425-18047 
C    RELOC: 92425-1X047 
C     PRGM: DICK LAMPMAN
************************************************************************* 
C    (C) *OPYRIGHT HEWLETT-PACKARD *OMPANY 1979. ALL RIGHTS             * 
C    RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,             *
C   REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT        * 
C   THE PRIOR WRITTED *ONSENT OF HEWLETT-PACKARD *OMPANY.               * 
************************************************************************* 
C 
C-------------------------------------------------------------
C 
C     USES THE FOLLOWING SUBROUTINES: 
C          DATE     SCAN      CLOSE 
C          TIMEX    RMPAR     EXEC
C          TABS     MESSS 
C          ATACH    OPEN
C          ASCII    READF 
C          INTV     JDRTP 
C 
C 
C 
C     THIS ROUTINE  OPENS THE WELCOM FILE AND LOOKS 
C FOR RECORDS BEGINNING WITH ':* #' . THE FOUR NUMBERS FOLLOWING
C REPRESENT: (1) THE STATION NUMBER; (2) THE LU OF THE DEVICE; (3)
C THE UNIT NUMBER; AND (4) THE DEVICE TYPE.  THESE ARE THEN STORED
C IN THE DRTXX WHICH IS MEMORY RESIDENT. THIS ROUTINE ALSO USE TO 
C PROMPT THE OPERATOR FOR THE DATE AND TIME TO INITIALIZE THE RTE CLOCK.
C 
C   USE ROUINTES
C      ISN    TO RETURN TERMINAL SESSION LU.
C      LUDV   TO GET THE LU OF A PARTICULAR DEVICE
C      LU2ST  IF YOU HAVE AN LU AND WANT IT'S STATION ((SYS) LU.
C             THIS ROUTINE IS GOOD ONLY FOR PROGRAMS NOT RUNNING
C             UNDER A SESSION.
C 
C 
C     FORMAT OF TEMPORARY DATA STORAGE BUFFERS
C     IDRT1 (I)   Y YYY YYY YEE EEE EEE 
C                 Y = SYSTEM LU 
C                 E = SESSION LU
C     IDRT2 (I)   R RRD DDD DDD DDU UUU 
C                 R = RESERVED
C                 D = DEVICE TYPE 
C                 U = UNIT
C     IDRT3 (I)   R RRR RRR RCC CCC CCC 
C                 R = RESERVED
C                 C = CLUSTER NUMBER
C 
C 
C 
      DIMENSION  IDCB(150)
      DIMENSION  IDCNT (255),IDRT1(512),IDRT2(512),IDRT3(512) 
      DIMENSION NAME3(3), IPARM(5), NAME5(3) ,NSLC (3)
      DIMENSION NAME4(3), IBUF(50), IDSEG(30), LU6SW(4) 
      DIMENSION ITOKN(30), ISTR1(9), NAME6(3) 
      DIMENSION NAME7(3), ICOMA(2), IHR(5), MIN(5), IYR(5)
      DIMENSION IDAYR(5), MON(5), MONDA(12), ISTAT(128) 
      DIMENSION ISTNS(20) 
C 
      DIMENSION IH1(6), IH2(5), IH3(15), IH4(15)
      DIMENSION ICH1(11),ICH2(5)
      DIMENSION ISL1(7) 
      DIMENSION IT0(6)
      DIMENSION IT1(8),IT2(8),IT3(4),IT4(6),IT5(9),IT6(8),IT7(12) 
      DIMENSION IXER (5)
      DIMENSION IT8(6),IT9(4),IT10(2) 
      DIMENSION IE1(23),IE2(12),IE3(12),IE4(21),IE5(18),IE6(20) 
      DIMENSION IE7(19),IE8(26) 
C 
      DATA NAME4 / 2HWE, 2HLC, 2HOM / ,NSLC / 2H/S, 2HLC, 2H   /
      DATA ICOMA / 1, 2H,   / 
      DATA MONDA / 0, 31, 59 ,90, 120, 151, 181, 212, 
     X             243, 273, 304, 334 / 
      DATA ISTNS/0,0,-1,1,-1,2,-1,3,-1,4,-1,5,-1,6,-1,7/
C 
      DATA IH1/   5 ,2H:S ,2HV, ,2H4, ,2H4, ,2HIH  /
      DATA IH2/   4 ,2H:C ,2HA, ,2H2, ,2H0 /
      DATA IH3/   5 ,2H:C ,2HA, ,2H6: ,2HP, ,2H0  / 
      DATA IH4/  14 ,2H:D ,2HP, ,2HSE ,2HLE ,2HCT ,2HED , 
     C2H C ,2HLU ,2HST, 2HER, 2H I ,2HS  ,2H,1 ,2HG  /
      DATA ICH1/   9,2H:I ,2HF, ,2H1G ,2H,N ,2HE, ,2H00 ,2H0, , 
     C2H+0 ,2H00 /
      DATA ICH2/   4,2H:C ,2HA, ,2H2, ,2H1G/
      DATA ISL1/   6,2H:S ,2HL, ,2H00 ,2H00 ,2H,0 ,2H00  /
      DATA IT0/    5,2H:C ,2HA, ,2H1: ,2HP, ,2H0  / 
      DATA IT1/    7,2H:I ,2HF, ,2H6P ,2H,E ,2HQ, ,2H0, ,2H+3 / 
      DATA IT2/    7,2H:D ,2HP, ,2HER ,2HRO ,2HR ,2H/S ,2HLC /
      DATA IT3/    3,2H:? ,2H?, ,2H6P / 
      DATA IT4/    5,2H:C ,2HA, ,2H1: ,2HP, ,2H-1 / 
      DATA IT5/    8,2H:I ,2HF, ,2H1G ,2H,E ,2HQ, ,2H2G ,2H,+ ,2H3  / 
      DATA IT6/    7,2H:D ,2HP, ,2HER ,2HRO ,2HR  ,2H/S ,2HLC / 
      DATA IT7/   11,2H:D ,2HP, ,2HCL ,2HUS ,2HTE ,2HR  ,2HNO , 
     C2HT  ,2HFO ,2HUN ,2HD / 
      DATA IT8/    5,2H:C ,2HA, ,2H1: ,2HP, ,2H-2/
      DATA IT9/    3,2H:S ,2HV, ,2H4G / 
      DATA IT10/   1,2H:: / 
C 
      DATA IE1/    22,2H *,2H**,2H C,2HON,2HVE,2HRS,2HIO,2HN ,
     C2HER,2HRO,2HR ,2HIN,2H S,2HET,2HTI,2HNG,2H D
     C,2HRT,2HXX,2H T,2HAB,2HLE / 
      DATA IE2/    11,2H D,2HRT,2HXX,2H O,2HVE,2HRF,2HLO,2HW
     C,2HER,2HRO,2HR /
      DATA IE3/    10,2H D,2HRT,2HXX,2H A,2HCC,2HES,2HS , 
     C 2HER,2HRO,2HR  / 
      DATA IE4/    19,2H *,2H**,2H S,2HTA,2HRT,2H E,2HRR,2HOR,2H. , 
     C2HOU ,2HT ,2HOF ,2H R,2HAN,2HGE,2H V,2HAL,2HUE ,2H.  /
      DATA IE5/    17,2H *,2H**,2H F,2HMG,2HR ,2HER,2HRO,2HR
     C,2H-0,2H00,2H0. 
     C,2HNA,2HMR,2H =,2H /,2HSL,2HC  /
      DATA IE6/    18,2H *,2H**,2H T,2HOO,2H M,2HAN,2HY ,2HDE 
     C,2HVI,2HCE,2HS ,2HIN,2H C,2HLU,2HST,2HER
     C,2H00,2H00 /
      DATA IE7/    18,2H *,2H**,2H F,2HMG,2HR ,2HER,2HRO,2HR
     C,2H-0,2H00,2H0. 
     C,2HNA,2HMR,2H =,2H W,2HEL,2HCO,2HM /
      DATA IE8/    25,2H *,2H** ,2HST ,2HAR ,2HT ,2HER,2HRO,2HR  ,
     C 2HCO,2HRR,2HUP,2HT ,2HCO,2HNF,2HIG,2HUR,2HAT,2HIO,2HN ,
     C 2HTA,2HBL,2HE ,2HIN,2H S,2HAM/ 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
      CALL RMPAR(IPARM) 
      LUOP = IPARM(1) 
      IF (LUOP .EQ. 0) LUOP = 1 
      ICRNS = IPARM (3) 
      IF (ICRNS.EQ.0) ICRNS = -2
C     CLEAR EXIT ERROR FLAG 
      IXER = 0
      ICRNW = IPARM (4) 
      IF (ICRNW.EQ.0) ICRNW = -2
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C* #C********************************************************************** 
C* #C     FOLLOWING CODE WAS SUPPRESSED AS PART OF UPGRADE
C* #C      FROM RTE IVA TO RTE IVB. 
C* #C 
C* #C     GET TIME SET UP 
C* #C 
C* #      WRITE (LUOP, 1003)
C* #1003  FORMAT ("BY ENTERING DATE AS MO/DA/YR #_")
C* #      READ (LUOP, 1002) (IBUF(J), J = 2,10) 
C* #      IBUF(1) = 8 
C* #      NTOKN = 0 
C* #      CALL SCAN (IBUF, MON, NTOKN, IQT) 
C* #      CALL SCAN (IBUF, ITOKN, NTOKN, IQT) 
C* #      CALL SCAN (IBUF, IDAYR, NTOKN, IQT) 
C* #      CALL SCAN (IBUF, ITOKN, NTOKN, IQT) 
C* #      CALL SCAN (IBUF, IYR,   NTOKN, IQT) 
C* #      WRITE (LUOP, 1001)
C* #1001  FORMAT ("AND ENTERING TIME AS HR:MM (24-HOUR CLOCK) #_")
C* #      READ (LUOP, 1002) (IBUF(I), I=2,10) 
C* #1002  FORMAT (10A2) 
C* #      IBUF(1) = 5 
C* #      NTOKN = 0 
C* #      CALL SCAN (IBUF, IHR, NTOKN, IQT) 
C* #      CALL SCAN (IBUF, ITOKN, NTOKN, IQT) 
C* #      CALL SCAN (IBUF, MIN, NTOKN, IQT) 
C* #      IDCB(1) = 5 
C* #      IDCB(2) = 2HTM
C* #      IDCB(3) = 2H,1
C* #      IDCB(4) = 2H9 
C* #      M = INTV(MON, IERR) 
C* #      IDAY = INTV (IDAYR) 
C* #      IXX = MONDA(M) + IDAY 
C* #      JYR = INTV (IYR, IERR)
C* #      ILPYR = JYR - 4 * (JYR / 4) 
C* #      IF ((ILPYR .EQ. 0) .AND. (M .GT. 2)) IXX = IXX + 1
C* #      CALL ASCII (IDAYR, IXX) 
C* #      CALL ATACH (IDCB, IYR)
C* #      CALL ATACH (IDCB, ICOMA)
C* #      CALL ATACH (IDCB, IDAYR)
C* #      CALL ATACH (IDCB, ICOMA)
C* #      CALL ATACH (IDCB, IHR)
C* #      CALL ATACH (IDCB, ICOMA)
C* #      CALL ATACH (IDCB, MIN)
C* #      I = MESSS (IDCB(2), IDCB(1))
C* #      IBUF(1) = 0 
C* #      CALL DATE (IBUF)
C* #      CALL TIMEX(ITOKN) 
C* #      CALL TABS (IBUF, 20)
C* #      CALL ATACH (IBUF, ITOKN)
C* #      WRITE (LUOP, 1004) (IBUF(J), J=2,18)
C* #1004  FORMAT ("SYSTEM DATE AND TIME ARE ",20A2) 
C* #
C* #C****************************************************************** 
C 
C 
C 
C     CLEAR CONFIGURATION TABLES AND DRTXX. 
C 
C 
100   CONTINUE
C     GET TERMINAL TABLE LENGTH AND INVALIDATE THE DRTXX TABLE. 
      INDRT = 1 
      CALL JDRTG (INDRT,J)
C     SERIOUS ERROR IF PROBLEM OCCURS ON FIRST DRTXX LOCATION 
      CALL ABREG (IA,IB)
      IF (IB.NE.0) GOTO 8029
      CALL JDRTP (INDRT,0)
C 
C 
101   CONTINUE
C     CLEAR THE CONFIGURATION TABLES. 
      INDRT = INDRT + 2 
      J = J - 2 
      IF (J.LT.0) GOTO 104
      CALL JDRTG (INDRT,IFCLS)
      IF (IFCLS.EQ.0) GOTO 101
      IBUF = IFCLS
C 
102   ICL = IAND (IBUF(1),17777B) 
      LEN = 2 
      CALL EXEC (21,ICL,IBUF,LEN) 
      IF (IBUF(1).NE.IFCLS) GOTO 102
      IF (IBUF(1).EQ.0 .OR. LEN.EQ.0) GOTO 8080 
      GOTO 101
C 
104   CONTINUE
      INDRT = 0 
105   INDRT = INDRT + 1 
      CALL JDRTP (INDRT,0)
      CALL ABREG(IA,IB) 
      IF (IB.EQ.0) GOTO 105 
C 
C     SET THE DRTXX INDEX TO FIRST LOCATION FOR TERMINAL DATA.
      INDRT = 2 
C 
C     PROCESS WELCOM FILE 
C 
200   CALL OPEN (IDCB, IERR, NAME4, 1,0,ICRNW)
      IF (IERR .LT. 0) GO TO 8070 
      ILCNT = 1 
C 
4000  CONTINUE
C     RETURN HERE IF ERROR FOUND IN LINE. 
      ILCNT = ILCNT - 1 
C 
C     SEARCH FOR NEXT CONFIGURATION LINE IN WELCOM
4001  CALL READF (IDCB, IERR, IBUF(2), 50, LEN) 
C     END OF WELCOM?
      IF (LEN .LT. 0) GO TO 4099
      IBUF(1) = 2 * LEN 
      IF (IBUF(2) .NE. 2H:*) GO TO 4001 
      IF (LEN .LT. 2) GO TO 4001
      IF (IBUF(3) .EQ. 2H #) GO TO 250
      GO TO 4001
C 
C*********************************************************************
250   CONTINUE
C     INCREMENT LINE COUNT
      ILCNT = ILCNT + 1 
C     SCAN FOR <CLSTR> <SYS> <SES> <UNIT#> <DEV TYPE> 
C 
C     CLSTR 
C 
      NTOKN = 5 
      CALL SCAN (IBUF, ITOKN, NTOKN, IQT) 
      ICCLS = INTV(ITOKN, IERR) 
      IF (IERR .NE. 0) GO TO 800
      IF(ICCLS.GT.255.OR.ICCLS.LT.1) GOTO 8030
C 
      IDRT3(ILCNT) = ICCLS
C 
C     SYSTEM LU 
C 
      CALL SCAN (IBUF,ITOKN,NTOKN,IQT)
      ISYSL = INTV (ITOKN,IERR) 
      IF (IERR.NE.0) GOTO 800 
      IF (ISYSL.GT.255.OR.ISYSL.LT.1) GOTO 8030 
C 
C     SESSION LU
C 
C 
      CALL SCAN (IBUF,ITOKN,NTOKN,IQT)
      ISESL = INTV (ITOKN,IERR) 
      IF (IERR.NE.0) GOTO 800 
      IF (ISESL.GT. 63.OR.ISESL.LT.1) GOTO 8030 
C 
      IDRT1 (ILCNT) = ISYSL*400B + ISESL
C 
C     UNIT
C 
      CALL SCAN (IBUF,ITOKN,NTOKN,IQT)
      IUNIT = INTV (ITOKN,IERR) 
      IF (IERR.NE.0) GOTO 800 
      IF (IUNIT.GT.15.OR.IUNIT.LT.1) GOTO 8030
C 
C     DEVICE TYPE 
C 
      CALL SCAN (IBUF,ITOKN,NTOKN,IQT)
      IDVT = INTV (ITOKN,IERR)
      IF (IERR.NE.0) GOTO 800 
      IF (IDVT.GT.511.OR.IDVT.LT.1) GOTO 8030 
C 
      IDRT2 (ILCNT) = IDVT * 20B + IUNIT
C 
C     INCREMENT TERMINAL COUNT IF SESSION TERMINAL. 
      IF (IDVT.NE.1 .OR. IUNIT.NE.1 .OR. ISESL.NE.1) GOTO 4025
      ITCNT = ITCNT+1 
C 
C     SET TERMINAL SYSTEM LU IN DRTXX.
C         TERMINAL CLUSTER NUMBER IS PUT IN BY ANOTHER PROGRAM. 
      CALL JDRTP (INDRT,ISYSL)
      CALL ABREG(IA,IB) 
      IF (IB.NE.0) GOTO 8010
      INDRT = INDRT + 1 
C     CLEAR TERMINALS STARTING CLASS NUMBER.
      CALL JDRTP (INDRT,0)
      CALL ABREG(IA,IB) 
      IF (IB.NE.0) GOTO 8010
      INDRT = INDRT + 1 
C     TERMINAL TABLE LENGTH IN DRTXX IS NOT PUT IN DRTXX UNTIL
C      ALL OTHER DATA HAS BEEN PUT IN. TERMINAL TABLE LENGTH
C      SERVES AS FLAG THAT TABLE IS INVALID.
       GOTO 4030
C 
4025  CONTINUE
C     INCREMENT DEVICE COUNT FOR CLUSTER IF NOT SESSION TERMINAL. 
      IDCNT (ICCLS) = IDCNT (ICCLS) + 1 
C 
4030  CONTINUE
C     GOTO NEXT LINE
      GOTO 4001 
C 
C*******************************************************************
 4099 CONTINUE
C 
C     RELEASE WELCOM FILE 
      CALL CLOSE (IDCB,IERR)
      IF (IERR.LT.0) GOTO 8030
********************************************************************* 
C 
C     PREPARE /SLC. 
      CALL PURGE (IDCB,IERR,NSLC,2HRT,ICRNS   ) 
      IF (IERR.NE.0 .AND. IERR.NE.-6) GOTO 8060 
      CALL CREAT (IDCB,IERR,NSLC,24,4,2HRT,ICRNS) 
      IF (IERR.LT.0) GOTO 8060
C 
C******************************************************************** 
C 
C     PUT HEADER IN /SLC
C 
      CALL WRITF (IDCB,IERR,IH1(2),IH1       )
      IF (IERR.LT.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IH2(2),IH2       )
      IF (IERR.LT.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IH3(2),IH3       )
      IF (IERR.LT.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IH4(2),IH4       )
      IF (IERR.LT.0) GOTO 8060
C 
C******************************************************************** 
C     INITIALIZE CURRENT CLUSTER NUMBER.
      ICCLS  = 0
C     LOCATE THE NEXT CLUSTER TO GO INTO /SLC AND DRTXX.
 5005 CONTINUE
      ICCLS = ICCLS + 1 
C     CHECK IF ALL CLUSTERS HAVE BEEN SCANNED.
      IF (ICCLS.GT.255 ) GOTO 6700
C     IS THIS CLUSTER USED? 
      ILCLS = IDCNT (ICCLS) 
      IF (ILCLS .NE.0) GOTO 5010
      GOTO 5005 
 5010 CONTINUE
C     THIS CLUSTER IS USED. 
C     PUT CLUSTER PARAMETERS IN DRTXX.
      CALL JDRTP (INDRT,ICCLS)
      CALL ABREG(IA,IB) 
      IF (IB.NE.0) GOTO 8010
      INDRT = INDRT + 1 
C 
      J = 2 * ILCLS 
      CALL JDRTP (INDRT,J)
      CALL ABREG(IA,IB) 
      IF (IB.NE.0) GOTO 8010
      INDRT = INDRT + 1 
C 
C     PUT CLUSTER HEADER IN COMMAND FILE. 
C      IN THE FIRST HEADER PUT THE CLUSTER NUMBER AND 
C       THE NUMBER OF LINES TO NEXT CLUSTER.
       ICH1 ( 7) = 2H00 + 246*(ICCLS/100) + ICCLS/10
       ICH1 ( 8) = 2H0, + 256 * (ICCLS - 10*(ICCLS/10) )
C      REJECT LENGTH IF NOT VALID.
       IF (ILCLS.GT.63) GOTO 8170 
      ILTGO = ILCLS + 1 
      ICH1 ( 9) = 2H+0 + ILTGO/100
      ICH1 (10) = 2H00 + ILTGO + 246*(ILTGO/10) 
     C-2560*(ILTGO/100) 
      CALL WRITF (IDCB,IERR,ICH1(2),ICH1) 
      IF (IERR.LT.0) GOTO 8060
      ILTGO = ILTGO -1
C 
      CALL WRITF (IDCB,IERR,ICH2(2),ICH2) 
      IF (IERR.LT.0) GOTO 8060
      ILTGO = ILTGO - 1 
C 
C******************************************************************** 
C 
C     NOW PUT THE DATA FOR ALL DEVICES OF THE CURRENT CLUSTER 
C      INTO /SLC AND DRTXX. 
      ICCNT = 0 
C 
6000  CONTINUE
      ICCNT = ICCNT + 1 
C     GO TO END OF CLUSTER PROCESSING IF AT END OF DEVICES. 
      IF (ICCNT.GT.ILCNT) GOTO 6500 
C 
C     IS CURRENT DEVICE IN CURRENT CLUSTER? 
      IF (IAND(IDRT3(ICCNT),377B).NE.ICCLS) GOTO 6000 
C 
C 
C     DO NOT STORE ANY DATA FOR SESSION TERMINALS.
      IF(IDRT2(ICCNT).EQ.21B.AND.IAND(IDRT1(ICCNT),377B).EQ.1)GOTO6000
C 
C     PUT DEVICE TYPE AND UNIT INTO DRTXX 
      CALL JDRTP (INDRT,IDRT2(ICCNT)) 
      CALL ABREG(IA,IB) 
      IF (IB.NE.0) GOTO 8010
      INDRT = INDRT + 1 
C 
C     PUT SESSION LU INTO DRTXX.
      CALL JDRTP (INDRT,IDRT1(ICCNT) )
      CALL ABREG(IA,IB) 
      IF (IB.NE.0) GOTO 8010
      INDRT = INDRT + 1 
C 
C     PUT SL COMMAND INTO /SLC. 
      ISYSL = IDRT1(ICCNT)
      ISESL = IAND (ISYSL,377B) 
      ISYSL = ISYSL / 400B
C 
      ISL1(4) = 2H00 + ISESL/100
      ISL1(5) = 2H00 + ISESL + 246*(ISESL/10) - 2560*(ISESL/100)
C 
      ISL1(6) = 2H,0 + ISYSL/100
      ISL1(7) = 2H00 + ISYSL + 246*(ISYSL/10) - 2560*(ISYSL/100)
C 
      CALL WRITF (IDCB,IERR,ISL1(2),ISL1) 
      IF (IERR.NE.0) GOTO 8060
      ILTGO = ILTGO - 1 
C 
C     GO BACK AND SEARCH FOR NEXT DEVIC.
      GO TO 6000
C 
C************************************************************** 
6500  CONTINUE
C     PUT END OF CLUSTER DATA INTO /SLC AND DRTCXX
C 
C      AT THIS TIME THERE IS NO END OF CLUSTER DATA.
      GOTO 5005 
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
6700  CONTINUE
C 
C     END OF CLUSTERS. PUT FINAL DATA IN /SLC AND DRTXX.
C 
C     FIRST FINISH /SLC BEFORE VALIDATING DRTXX 
      CALL WRITF (IDCB,IERR,IT0(2),IT0) 
      IF (IERR.NE.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IT1(2),IT1) 
      IF (IERR.NE.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IT2(2),IT2) 
      IF (IERR.NE.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IT3(2),IT3) 
      IF (IERR.NE.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IT4(2),IT4) 
      IF (IERR.NE.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IT5(2),IT5) 
      IF (IERR.NE.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IT6(2),IT6) 
      IF (IERR.NE.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IT7(2),IT7) 
      IF (IERR.NE.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IT8(2),IT8) 
      IF (IERR.NE.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IT9(2),IT9) 
      IF (IERR.NE.0) GOTO 8060
      CALL WRITF (IDCB,IERR,IT10(2),IT10) 
      IF (IERR.NE.0) GOTO 8060
C 
C     CLOSE /SLC
      CALL CLOSE (IDCB,IERR)
      IF (IERR.NE.0) GOTO 8060
C 
C     NOW PUT END OF DATA FLAG IN DRTXX 
      CALL JDRTP (INDRT,0)
      CALL ABREG (IA,IB)
      IF (IB.NE.0) GOTO 8010
      INDRT = INDRT + 1 
C 
C     NOW VALIDATE DRTXX
      I = 2*ITCNT 
      CALL JDRTP (1,I)
      CALL ABREG(IA,IB) 
      IF (IB.NE.0) GOTO 8010
C 
C     ALL DONE. 
      GOTO 900
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C 
C     ERROR REPORTING STARTS HERE.
C 
800   CONTINUE
      IXER = -1 
      CALL REIO (2,LUOP,IE1(2),IE1) 
      CALL REIO (2,LUOP,IBUF(2),LEN)
      GO TO 4000
C 
C     TROUBLE STORING MORE THAN ONE ENTRY IN DRTXX. 
8010  CONTINUE
      IXER = -2 
      CALL REIO (2,LUOP,IE2(2),IE2) 
C     CALL CLOSE (IDCB) 
      GOTO 900
C 
C 
8029  CONTINUE
      IXER = -3 
C     FIRST ATTEMPT TO ACCESS DRTXX FAILED. 
      CALL REIO (2,LUOP,IE3(2),IE3) 
      GOTO 900
C 
8030  CONTINUE
      IXER = -4 
C     OUT OF RANGE VALUE. 
      CALL REIO (2,LUOP,IE4(2),IE4) 
      CALL REIO (2,LUOP,IBUF(2),LEN)
      GOTO 4000 
C 
8060  CONTINUE
      IXER     = -5 
      IXER (2) = IERR 
C     FMGR ERROR ON FILE /SLC 
      J = 2H+0
      IF (IERR.GE.0) GOTO 8061
      IERR = -IERR
      J = 2H-0
8061  CONTINUE
      I = IERR/1000 
      IE5(10) = J + I 
      J = IERR - I*1000 
      IE5(11) = 2H00 + 246*(J/100) + J/10 
      IE5(12) = 2H0. + 256 * ( J - 10*(J/10) )
      CALL REIO (2,LUOP,IE5(2),IE5) 
      CALL CLOSE (IDCB) 
      GOTO 900
C 
8070  CONTINUE
      IXER     = -5 
      IXER (2) = IERR 
C     FMGR ERROR ON FILE WELCOM.
      J = 2H+0
      IF (IERR.GE.0) GOTO 8071
      IERR = -IERR
      J = 2H-0
8071  CONTINUE
      I = IERR/1000 
      IE7(10) = J + I 
      J = IERR - I*1000 
      IE7(11) = 2H00 + 246*(J/100) + J/10 
      IE7(12) = 2H0. + 256 * ( J - 10*(J/10) )
      CALL REIO (2,LUOP,IE7(2),IE7) 
      CALL CLOSE (IDCB) 
      GOTO 900
C 
8080  CONTINUE
C     ERROR IN RELEASING CLASS I/O BUFFERS AND NUMBERS. 
      CALL REIO (2,LUOP,IE8(2),IE8) 
      IXER = -7 
C     CONTINUE TO TRY TO RELEASE REMAINING BUFFERS. 
      GOTO 101
C 
8170  CONTINUE
      IXER  = -6
C     NUMBER OF DEVICES EXCEEDS LIMIT.
      CALL REIO (2,LUOP,IE6(2),IE6) 
C 
C     DONE
C 
900   CONTINUE
      CALL PRTN (IXER)
      IF (IXER.NE.0) CALL JDRTP(1,0)
      CALL EXEC(6)
      END 
      END$