FTN4,L
      SUBROUTINE C45IM(IUNIT,ISLA,ISLB,TRIGA,TRIGB),
     +09580-16413 REV.2001 791023 
C-------------------------------------------------------------------
C 
C      RELOC.       09580-16413 
C      SOURCE       09580-18413 
C      REV. A       Y.MIYAKO  3-13-79 
C      790515       Y.MIYAKO
C      791023       BOB RICHARDS
C 
C 
C      HP 92425B TEST SYSTEM SOFTWARE IS THE PROPRIETARY
C      MATERIAL OF THE HEWLETT-PACKARD COMPANY.  USE AND
C      DISCLOSURE THEREOF ARE RESTRICTED BY WRITTEN AGREEMENT.
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     C45IM(I,I,I,R,R),     OV#=XX,     ENT=C45IM, FIL=%C45IM 
C 
C-------------------------------------------------------------------
      DIMENSION IERMS(5)
      DATA IERMS/10,5,2HC4,2H5I,2HM / 
      IERMS = 10
      ISTN = ISN(DUM) 
      LU = LUDV(ISTN,6,IUNIT) 
      LUIB = IBLU0(LU)
      IF(LU)800,800,10
10    CALL X45IM(LUIB,LU,IERMS,ISLA,ISLB,TRIGA,TRIGB) 
      IF(IERMS)800,20,800 
20    RETURN
C 
C 
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
      SUBROUTINE X45IM(LUIB,LCTR,IERR,ISLA,ISLB,TRIGA,TRIGB), 
     +09580-16413 REV.2001 791023 
C 
C 
C 
C 
C 
C       THIS DEVICE SUBROUTINE SETS UP THE 5345A
C       ELECTRONIC COUNTER FUNCTIONS. 
C 
C     CALL C45IM(LUIB,LCTR,IERR,ISLA,ISLB,TRIGA,TRIGB)
C        WHERE: 
C              LUIB  = LU OF HPIB INTERFACE CARD
C              LCTR  = LU OF HP 5345A ELECTRONIC COUNTER
C 
C              IERR  = 5 ELEMENT ERROR ARRAY
C                      IERR(1) = ERROR CODE 
C 
C                        0= NO ERROR
C                        1= PARAMETER ERROR 
C     ERROR MESSAGES WHICH PERTAIN TO THE HPIB
C 
C     9 = I/O CALL REJECTED 
C     10 = LU NOT ASSIGNED TO HPIB DEVICE OR TO STATION.
C     11 - DMA INPUT REQUEST PREMATURELY TERMINATED 
C     12 - I/O DEVICE TIME OUT
C     13 - IFC (INTERFACE CLEAR) DETECTED DURING I/O REQUEST
C     14 - SRQ SERVICE ABORTED
C     15 - NON-EXISTENT ALARM PROGRAM 
C     16 - ILLEGAL CONTROL REQUEST
C     17 - EQT EXTENSION AREA FULL, NO NEW DEVICE MAY BE ADDED ON LINE
C 
C                      IERR(3) - IERR(5) = DEVICE SUBROUTINE NAME 
C 
C              ISLA  = A CHANNEL SLOPE
C              ISLB  = B CHANNEL SLOPE
C                      0    - SLOPE 
C                      1    + SLOPE 
C 
C              TRIGA = A CHANNEL TRIGGER LEVEL
C              TRIGB = B CHANNEL TRIGGER LEVEL
C                      -2.000<= TRIG <= 1.999 
C 
C 
C 
C 
C 
      DIMENSION IBUF(6),IADG(3),IRNG(2),IERR(5),IREG(2) 
C 
      EQUIVALENCE(REG,IREG,IA),(IREG(2),IB) 
C 
C 
C  SET PROGRAM DATA 
C 
      DATA IWRT/100002B/
      DATA IRNG/100,10/ 
C  INITILIZE ERROR
      IERR=0
C 
      IF(TRIGA.LT.-2.000.OR.TRIGA.GT.1.999)GOTO 9100
      IF(TRIGB.LT.-2.000.OR.TRIGB.GT.1.999)GOTO 9100
C 
      IF(ISLA .LT. 0 .OR. ISLA .GT. 1) GOTO 9100
      IF(ISLB .LT. 0 .OR. ISLB .GT. 1) GOTO 9100
C 
C  SET A CHANNEL SLOPE
C 
      IF(ISLA.EQ.0)IBUF(1)=2HE> 
      IF(ISLA.EQ.1)IBUF(1)=2HE6 
C 
C  COMPUTE A CHANNEL TRIGGER LEVELS 
C 
C 
      ITRIG=(TRIGA+2.0)*250.0 
      DO 100 I=1,2
      IADG(I)=0 
50    IF(ITRIG.LT.IRNG(I))GOTO 100
      IADG(I)=IADG(I)+1 
      ITRIG=ITRIG-IRNG(I) 
      GOTO 50 
100   CONTINUE
      IBUF(2)=(40460B+IADG(1))
      IBUF(3)=IOR((IADG(2)+60B)*256,ITRIG+60B)
C 
C  SET B CHANNEL SLOPE
C 
      IF(ISLB.EQ.0)IBUF(4)=2HE8 
      IF(ISLB.EQ.1)IBUF(4)=2HE0 
C 
C  COMPUTE B CHANNEL TRIGGER LEVEL
C 
C 
      ITRIG=(TRIGB+2.0)*250.0 
      DO 200 I=1,2
      IADG(I)=0 
150   IF(ITRIG.LT.IRNG(I))GOTO 200
      IADG(I)=IADG(I)+1 
      ITRIG=ITRIG-IRNG(I) 
      GOTO 150
200   CONTINUE
      IBUF(5)=(41060B+IADG(1))
      IBUF(6)=IOR((IADG(2)+60B)*256,ITRIG+60B)
C 
500   CALL EXEC(100003B,1600B+LUIB) 
      GO TO 9000
550   CALL ABREG(IA,IB) 
      IF(IB.LT.0)GO TO 990
C 
C   PROGRAM ELECTRONIC COUNTER
C 
      CALL REIO(IWRT,2000B+LCTR,IBUF,6,IDUMY,0) 
      GO TO 9000
1000  CALL ABREG(IA,IB) 
      IF(IB.LT.0)GO TO 990
C 
C   RETURN
C 
      RETURN
C 
C   ERROR RETURN
C 
9000  IERR = 9
      GO TO 9900
9100  IERR = 1
      GO TO 9900
990   IERR = IAND(IREG,377B) + 11 
9900  IERR(2) = 5 
      IERR(3) = 2HC4
      IERR(4) = 2H5I
      IERR(5) = 2HM 
      RETURN
      END 
      END$
                                                                                                      