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 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$