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$