FTN4,L
      SUBROUTINE IBGSC(IUNIT,ICODE),09580-16452 REV.2001 790829 
C-----------------------------------------------------------
C 
C     THIS SUBROUTINE PROGRAMS THE 6940B/6941B USING THE 59500A.
C 
C     RELOC.                  09580-16452 
C     SOURCE                  09580-18452 
C 
C     BOB RICHARDS 790829 
C 
C     TEST SYSTEM SOURCE SOFTWARE IS THE PROPRIETRY 
C     MATERIAL OF THE HEWLETT-PACKARD COMPANY.
C 
C     (C) COPYRIGHT  HEWLETT-PACKARD COMPANY  1979. 
C     ALL RIGHTS RESERVED.  NO PART OF THIS PROGRAM 
C     MAY BE PHOTOCOPIED, REPRODUCED OR TRANSLATED
C     TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR 
C     WRITTEN CONSENT OF THE HEWLETT-PACKARD COMPANY. 
C 
C-----------------------------------------------------------
C 
C     BRANCH AND MNEMONIC TABLES ENTRIES: 
C     ----------------------------------- 
C 
C     IBGSC(I,I),          OV=XX,         ENT=IBGSC,  FIL=%IBGSC
C 
C-------------------------------------------------------------- 
C 
C 
      DIMENSION IERMS(5)
      DATA IDTN/70/,IERMS/10/ 
C 
      ISTN = ISN(DUMMY) 
      LU = LUDV(ISTN,IDTN)
      LUIB = IBLU0(LU)
      IF (LU)800,800,20 
20    IFUNC = 1 
      CALL XBGSC(LU,LUIB,IERMS,IUNIT,IFUNC,ICODE) 
      IF(IERMS)800,30,800 
30    CONTINUE
      RETURN
C 
800   IERMS(2) = 5
      IERMS(3) = 2HIB 
      IERMS(4) = 2HGS 
      IERMS(5) = 2HC
      CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
      SUBROUTINE IBGSD(IUNIT,IDATA),09580-16452 REV.2001 790829 
C---------------------------------------------------------
C 
C     BRANCH AND MNEMONIC TABLES ENTRIES: 
C     ----------------------------------
C 
C     IBGSD(I,I),         OV=XX,             ENT=IBGSD,  FIL=%IBGSC 
C 
C---------------------------------------------------------
      DIMENSION IERMS(5)
      DATA IDTN/70/ 
      DATA IERMS/10,5,2HIB,2HGS,2HD / 
      ISTN = ISN(DUMMY) 
      LU = LUDV(ISTN,IDTN)
      LUIB = IBLU0(LU)
      IF (LU)800,800,20 
20    CALL XBGSD(LU,LUIB,IERMS,IUNIT,IDATA) 
      IF(IERMS)800,30,800 
30    CONTINUE
      RETURN
C 
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
      SUBROUTINE IBGSA(IUNIT,IGATE),09580-16452 REV.2001 790829 
C---------------------------------------------------------
C 
C     BRANCH AND MNEMONIC TABLES ENTRIES: 
C     ----------------------------------
C 
C     IBGSA(I,I),         OV=XX,             ENT=IBGSA,  FIL=%IBGSC 
C 
C---------------------------------------------------------
      DIMENSION IERMS(5)
      DATA IDTN/70/ 
      DATA IERMS/10,5,2HIB,2HGS,2HA / 
      ISTN = ISN(DUMMY) 
      LU = LUDV(ISTN,IDTN)
      LUIB = IBLU0(LU)
      IF (LU)800,800,20 
20    IFUNC = 3 
      CALL XBGSC(LU,LUIB,IERMS,IUNIT,IFUNC,IGATE) 
      IF(IERMS)800,30,800 
30    CONTINUE
      RETURN
C 
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
      SUBROUTINE IBGSR(IUNIT,IRTN),09580-16452 REV.2001 790829
C---------------------------------------------------------
C 
C     BRANCH AND MNEMONIC TABLES ENTRIES: 
C     ----------------------------------
C 
C     IBGSR(I,IV),         OV=XX,             ENT=IBGSR,  FIL=%IBGSC
C 
C---------------------------------------------------------
      DIMENSION IERMS(5)
      DATA IDTN/70/ 
      DATA IERMS/10,5,2HIB,2HGS,2HR / 
      ISTN = ISN(DUMMY) 
      LU = LUDV(ISTN,IDTN)
      LUIB = IBLU0(LU)
      IF (LU)800,800,20 
20    IFUNC = 4 
      CALL XBGSC(LU,LUIB,IERMS,IUNIT,IFUNC,IRTN)
      IF(IERMS)800,30,800 
30    CONTINUE
      RETURN
C 
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
C 
      SUBROUTINE XBGSC(LU,LUIB,IERMS,IUNIT,IFUNC,ICODE),
     +09580-16452 REV.2001 790829 
C 
C     THIS IS THE DEVICE SUBROUTINE FOR PROGRAMMING THE 
C     HP6940B USING THE HP-59500 .  THE PARAMETERS IN THE CALLING 
C     SEQUENCE HAVE THE FOLOWING MEANINGS:
C       LU = LOGICAL UNIT NUMBER OF 6940B 
C       LUIB = LOGICAL UNIT OF THE HP-IB CARD.
C       IERMS = 5 WORD ERROR ARRAY
C         WHERE IERMS(1) = ERROR CODE 
C                         0 = NO ERROR
C                         1 = PARAMETER ERROR 
C                         2 = I/O DEVICE DOWN OR TIME OUT 
C                         9 = I/O CALL REJECTED 
C                         10 = LU NOT ASSIGNED TO STATION 
C                              OR ILLEGAL LU
C               IERMS(2) = CHARACTER COUNT
C               IERMS(3) - IERMS(5) = DEVICE SUBROUTINE MNEMONICS 
C 
C       IUNIT = 6940 UNIT ADDRESS (1-15) - "IBGSC"
C             = SLOT ADDRESS (0-14 OR 400-414) - "IBGSD, IBGSA" 
C             = 59500A UNIT NUMBER - "IBGSR"
C 
C       IFUNC = FUNCTION CODE 
C               1 = CONTROL WORD
C               2 = DATA WORD 
C               3 = ADDRESS WORD
C               4 = READ
C 
C       ICODE = CONTROL MODE/ DATA WORD/ ADDRESS WORD 
C               CONTROL MODE: 
C               0 = SYE OFF             - OUTPUT MODE 
C               1 = SYE ON              - OUTPUT MODE 
C               2 = DTE, SYE ON         - OUTPUT MODE 
C               3 = DTE, SYE, TME ON    - OUTPUT MODE 
C               4 = ISL, SYE ON         - INPUT MODE
C               5 = ISL, SYE, TME ON    - INPUT MODE
C               6 = IEN, SYE, TME ON    - INPUT MODE
C 
C             = DATA WORD 
C                  12-BIT WORD
C 
C             = ADDRESS WORD
C               0 = READ WITH GATE
C               1 = READ WITHOUT GATE 
C               2 = READ "ON THE FLY" 
C 
C             = READ
C                 = RETURNED INTEGER VALUE
C 
C 
C---------------------------------------------------------------- 
C 
      DIMENSION ICNWD(7),IREG(2),IERMS(5),IOBUF(3)
      EQUIVALENCE (REG,IREG,IA),(IREG(2),IB)
      DATA ICNWD/0000B,0040B,0140B,0160B,0240B,0260B,0460B/ 
C 
C       CHECK PARAMETERS
C 
      IERMS = 0 
      IF(IFUNC.LT.1.OR.IFUNC.GT.4)GO TO 9900
      IF(IFUNC.EQ.2)GO TO 20
      IF(IFUNC.EQ.3)GO TO 700 
      IF(IFUNC.EQ.4)GO TO 800 
C 
C       CONTROL WORD
C 
      IF(ICODE.LT.0.OR.ICODE.GT.6)GO TO 9900
      IF (IUNIT.LT.0.OR.IUNIT.GT.15)GO TO 9900
      INX = ICODE+1 
      IWORD = IOR(ICNWD(INX),IUNIT) 
      GO TO 500 
C 
C        DATA WORD
C 
20    IWORD = ICODE 
      IF(IUNIT.LT.0.OR.IUNIT.GT.414)GO TO 9900
      IF(IUNIT.GT.14.AND.IUNIT.LT.400)GO TO 9900
      IF(IWORD.LT.0.OR.IWORD.GT.7777B)GO TO 9900
      INX = IUNIT 
      IF(IUNIT.GT.14)INX = IUNIT-400
      GOTO 600
C 
C        OUTPUT TO MULTIPROGRAMMER VIA THE 59500
C 
C     CONVERT TO ASCII
C 
C 
C     CONTROL WORD
C 
500   IOBUF(1) = 2HO0 
      TEMP0 = (((IAND(IWORD,700B)/100B)+60B)*400B)
      TEMP1 = ((IAND(IWORD,70B)/10B)+60B) 
      IOBUF(2) = TEMP0 + TEMP1
      TEMP0 = ((IAND(IWORD,7B)+60B)*400B) 
      IOBUF(3) = TEMP0 + 124B 
      NWORD = 3 
      GOTO 2000 
C 
C     DATA WORD 
C 
600   TEMP1 = (INX + 100B) * 400B 
      TEMP0 = ((IAND(IWORD,7000B)/1000B)+60B) 
      IOBUF(1) = TEMP1 + TEMP0
      TEMP1 = (((IAND(IWORD,700B)/100B)+60B)*400B)
      TEMP0 = ((IAND(IWORD,70B)/10B)+60B) 
      IOBUF(2) = TEMP1 + TEMP0
      TEMP1 = ((IAND(IWORD,7B)+60B)*400B) 
      IOBUF(3) = TEMP1 +124B
      NWORD = 3 
      GOTO 2000 
C 
C     ADDRESS WORD
C 
700   IF (IUNIT .LT. 0 .OR. IUNIT .GT. 414) GOTO 9900 
      IF (IUNIT .GT. 14 .AND. IUNIT .LT. 400) GOTO 9900 
      IF (IUNIT .GT. 14) IUNIT = IUNIT - 400
      IF (ICODE .LT. 0 .OR. ICODE .GT. 2) GOTO 9900 
      TEMP1 = (IUNIT + 100B) * 400B 
      IF (ICODE .EQ. 0) IOBUF(1) = TEMP1 + 124B 
      IF (ICODE .EQ. 1) IOBUF(1) = TEMP1 + 130B 
      IF (ICODE .EQ. 2) IOBUF(1) = TEMP1 + 132B 
      NWORD = 1 
      GOTO 2000 
C 
C  READ 
C 
800   NWORD = 3 
C 
C 
C  REMOTE ENABLE
C 
2000  CALL EXEC(100003B,1600B+LUIB) 
      GOTO 9000 
2010  CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
      IF (IFUNC .EQ. 4) GOTO 2100 
C 
C  SEND OUTPUT BUFFER 
C 
      CALL REIO(100002B,LU,IOBUF(1),NWORD,IDUMY,0)
      GOTO 9000 
2020  CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
      GOTO 3000 
C 
C  INPUT FROM 59500A
C 
2100  CALL REIO(100001B,LU,IOBUF(1),NWORD,IDUMY,0)
      GOTO 9000 
2110  CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
      CALL CODE 
      READ (IOBUF,2200) XCODE 
2200  FORMAT (F6.1) 
      ICODE = IFIX(XCODE) 
C 
C 
C  RETURN 
C 
3000  IERMS=0 
      RETURN
C 
C  ERROR EXIT 
C 
8500  IERMS=IAND(IA,377B)+11
      GOTO 8000 
9000  IERMS=9 
      GOTO 8000 
9900  IERMS = 1 
8000  IERMS(2)=5
      IERMS(3)=2HXB 
      IERMS(4)=2HGS 
      IERMS(5)=2HC
      RETURN
      END 
C 
      SUBROUTINE XBGSD(LU,LUIB,IERMS,IUNIT,IDATA),
     +09580-16452 REV.2001 790829 
C 
C     THIS SUBROUTINE SENDS DATA WORD TO MULTI-PROGRAMMER 
C 
      DIMENSION IAR(4),IERMS(5) 
      DATA IFUN/2/
C 
      IERMS = 0 
      IF(IUNIT.LT.0.OR.IDATA.LT.0)GO TO 8000
      IF(IUNIT.GE.400.AND.IUNIT.LE.414)GO TO 10 
      IF (IUNIT.LE.14)GO TO 10
      GO TO 8000
10    IER = 0 
      DO 20  J=1, 4 
20    IAR(J) = 0
C 
      IAR(1) = (IDATA/1000) 
      IAR(2) = ((IDATA - (IAR(1)*1000))/100)
      IAR(3) = ((IDATA - (IAR(1)*1000) - (IAR(2)*100))/10)
      IAR(4) = ((IDATA - (IAR(1)*1000) - (IAR(2)*100) 
     +- (IAR(3)*10))) 
C 
      DO 30 I = 1,4 
      IF (IAR(I) .LT. 0 .OR. IAR(I) .GT. 7) GOTO 8000 
30    CONTINUE
C 
      JDATA =IAR(1)*1000B+IAR(2)*100B+IAR(3)*10B+IAR(4) 
      CALL XBGSC(LU,LUIB,IERMS,IUNIT,IFUN,JDATA)
      IF(IERMS.EQ.0)RETURN
      GO TO 8100
C 
8000  IERMS = 1 
8100  IERMS(2) = 5
      IERMS(3) = 2HXB 
      IERMS(4) = 2HGS 
      IERMS(5) = 2HD
      RETURN
      END 
      END$
                                                                                                                                                                                                                                                              