FTN4,Q,C
      PROGRAM IBCFE (3,99),92425-16056 REV.2001 791231
C     NAME:IBCFE
C   SOURCE: 92425-18056 
C    RELOC: 92425-16056 
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, AND (5) THE IB FLAG.
C IF IB IS SET AND CLUSTER MATCHES THIS STATION, THEN THE DEVICE
C IS SENT THE STANDARD CONFIGURATION WORD WITH THE ERROR BIT SET. 
C 
C   USE ROUINTES
C      LOGLU  TO RETURN TERMINAL SESSION LU. (NOT ISN)
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 
C 
      DIMENSION  IDCB(150)
      DIMENSION NAME3(3), IPARM(5), NAME5(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 IE1(23),IE4(21),IEXRP(4)
C 
      DATA ICRN2/-2/ ,ICRN3/-3/ 
      DATA NAME4 / 2HWE, 2HLC, 2HOM / 
      DATA ICOMA / 1, 2H,   / ,ICNFG/17400B/
C 
      DATA IE1/    11,2H *,2H**,2H C,2HON,2HVE,2HRS,2HIO,2HN ,
     C2HER,2HRO,2HR / 
      DATA IE4/    12,2H *,2H**,2H O,2HUT,2H O,2HF ,2HRA,2HNG,2HE 
     C,2HVA,2HLU,2HE  / 
      DATA IEXRP/  3 ,2H:E ,2HX, ,2HRP /
C*******************************************************************
      CALL RMPAR(IPARM) 
      LUOP = IPARM(1) 
      IF (LUOP .EQ. 0) LUOP = 1 
C 
      ICRN = IPARM (4)
      IF (ICRN.EQ.0) ICRN = ICRN2 
C 
C******************************************************************** 
C 
C     SEARCH DRTXX FOR CURRENT CLUSTER. 
C 
C 
100   CONTINUE
      INDRT = 0 
C 
C     GET THE CURRENT STARTION NUMBER.
      ISN = LOGLU (LUSYS) 
C     CHECK IF IN SESSION 
      IF (LUSYS.LE.0) GOTO 8010 
C 
C     GET TERMINAL TABLE LENGTH AND CHECK FOR VALID DRTXX 
      CALL JDRTG (1,ITRLN)
      CALL ABREG (IA,IB)
      IF (IB.NE.0) GOTO 8020
      ITRLN =ITRLN/2
C 
C     SEARCH TABLE FOR THIS STATION 
      INDRT = 0 
111   CONTINUE
C     END OF TERMINAL TABLE?
      ITRLN = ITRLN - 1 
      IF (ITRLN.LT.0) GOTO 8025 
C 
      INDRT = INDRT + 2 
C 
      CALL JDRTG (INDRT,I)
      CALL ABREG (IA,IB)
      IF (IB.NE.0) GOTO 8020
C     CORRECT STATION FOUND?
      IF (IAND(I,377B) .NE. LUSYS) GOTO 111 
C     YES. EXTRACT THE CLUSTER NUMBER.
      ISCLS = IAND(I,077400B) / 400B
      IF (I.LT.0) ISCLS = ISCLS + 400B
C 
C 
C******************************************************************** 
C 
C     PROCESS WELCOM FILE 
C 
200   CALL OPEN (IDCB, IERR, NAME4, 1,0,ICRN) 
      IF (IERR .LT. 0) GO TO 8040 
      ILCNT = 0 
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 
      IF (ICCLS.NE.ISCLS) GOTO 4001 
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.255.OR.ISESL.LT.1) GOTO 8030 
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 
C 
C     IB
C 
      CALL SCAN (IBUF,ITOKN,NTOKN,IQT)
C     TWO CHARACTERS? 
      IF (ITOKN.NE.2) GOTO 4001 
C 
C     IB? 
      IF (ITOKN(2).NE.2HIB) GOTO 4001 
C 
C 
C     DISREGARD SESSION TERMINALS.
      IF (IDVT.EQ.1 .AND. IUNIT.EQ.1 .AND. ISESL.EQ.1) GOTO 4001
C 
C     TEST IF SESSION LU MATCHES SYSTEM LU. 
      IF (ISYSL.NE.LUTRU(ISESL) ) GOTO 8035 
C 
C     CONFIGURE THE DEVICE. 
      CALL EXEC (3,2500B+ISESL,ICNFG) 
C     GOTO NEXT LINE
      GOTO 4001 
C*******************************************************************
4099  CONTINUE
C     RELEASE WELCOM FILE 
      CALL CLOSE (IDCB) 
C     EXIT PROGRAM
      GOTO 900
C 
C*******************************************************************
800   CONTINUE
      CALL REIO (2,LUOP,IE1(2),IE1) 
      CALL REIO (2,LUOP,IBUF(2),LEN)
      GO TO 8999
C 
8010  CONTINUE
C     NOT IN SESSION. 
      WRITE (LUOP,8011) 
8011  FORMAT (/"*** IBCFE ERROR   NOT IN SESSION")
      GOTO 8999 
C 
8020  CONTINUE
C     DRTXX TABLE ACCESS ERROR
      WRITE (LUOP,8021) IB
8021  FORMAT (/"*** IBCFE ERROR   DRTXX ACCESS ERROR " I7)
      GOTO 8999 
C 
8025  CONTINUE
C     TERMINAL NOT IN DRTXX TABLE 
      WRITE (LUOP,8026) 
8026  FORMAT (/"*** IBCFE ERROR   TERMINAL NOT IN DRTXX TABLE") 
      GO TO 8999
C 
8030  CONTINUE
C     OUT OF RANGE VALUE. 
      CALL REIO (2,LUOP,IE4(2),IE4) 
      CALL REIO (2,LUOP,IBUF(2),LEN)
      GOTO 8999 
C 
8035  CONTINUE
C     SYS LU DOES NOT MATCH SESSION LU. 
      WRITE (LUOP,8036) (IBUF(I),I=2,IBUF(1)) 
8036  FORMAT ("*** IBCFE ERROR   SYSTEM LU NOT MAPPED TO SESSION LU." 
     C /,40A2)
      GOTO 8999 
C 
8040  CONTINUE
C     WELCOM FILE CANNOT BE OPENED
      WRITE (LUOP,8041) IERR
8041  FORMAT ("*** IBCFE ERROR    WELCOM FILE CANNOT BE OPENED. FMGR" 
     C" ERR ="I5".")
      GOTO 8999 
C 
C 
8999  CONTINUE
C     ERROR EXIT
      IF (IBUF.GE.0) IBUF = -1
      IBUF (2) = IERR 
      CALL PRTN (IBUF)
      CALL EXEC (6) 
C******************************************************************** 
C     DONE
C 
900   CONTINUE
      IBUF = 0
      CALL PRTN (IBUF)
      CALL EXEC (6) 
      END 
      END$
                                                                                                                                                                                                                                                              