FTN4,L
      SUBROUTINE DSVSU(IUNIT,R,IT,DD1), 
     +09580-16136 REV.2001 791023 
C***********************************************************
C 
C     RELOC.       09580-16136
C     SOURCE       09580-18136
C 
C 
C     R. UNTALAN     04 15 77    REV. A 
C                    770901  REV. B 
C                    790724  REV. C 
C    BOB RICHARDS    791023 
C 
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 
C 
C  GENERAL
C  -------
C      THE FOLLOWING DEVICE SUBROUTINE ALLOWS THE APPLICATION 
C  PROGRAMMER TO PROGRAM ALL RANGES,TRIGGER MODE (EXCEPT FOR HLD/MNL),
C  AND DELAY. ENABLE REQUEST IS DISABLED, THAT IS (RQS) IS PROGRAM FOR 0. 
C  THE 3437A IS PROGRAMMED TO OUTPUT PACKED(2-BYTE) FORMAT PER
C  READING TO ALLOW THE 3437A TO OPERATE AT MAXIMUM SPEED.
C 
C 
C  HARDWARE ENVIRONMENT:
C  ---------------------
C 
C     HP 21MX SERIES COMPUTER 
C     HP 3437A SYSTEM VOLTMETER 
C     HP 59310A/B INTERFACE BUS I/O KIT 
C 
C 
C  OUTPUT BUFFER (10 WORDS) 
C  ------------------------ 
C 
C     WORD 1 = RANGE
C     WORD 2 = TRIGGER MODE 
C     WORD 3 = PACKED FORMAT
C     WORD 4 = SRQ DISABLE
C     WORD 5 = ASCII  S,   (STORE COMMAND FOR SRQ CODE) 
C     WORD 6 = ASCII  D.   (PREFIX FOR DELAY PARAMETER) 
C     WORD 7 = XX     WHERE X = ASCII NUMBER 0-9
C     WORD 8 = XX 
C     WORD 9 = XX 
C     WORD 10= S  (STORE COMMAND FOR DELAY) 
C 
C 
C************************************************************ 
      DIMENSION IERMS(5)
      DATA IDT1,IDT2/9,43/
      DATA IERMS/10,5,2HDS,2HVS,2HU / 
C 
C INTERFACE MODULE FOR THE 3437A SET UP DEVICE
C SUBROUTINE
C 
C     IDT1=DEVICE TYPE NUM. FOR THE HPIB
C     IDT2=DEVICE TYPE NUM. FOR THE HP3437A SVM 
C     ERROR DSVSU-10 MEANS LU#=0 OR STATION#=0 OR UNIT # INCORRECT
C 
C 
      IERMS=10
      ISTN=ISN(DUMMY) 
      LU2=LUDV(ISTN,IDT2,IUNIT) 
      LU1=IBLU0(LU2)
      IF (ISTN.EQ.0.OR.LU1.EQ.0.OR.LU2.EQ.0) GO TO 500
      CALL XSVSU(LU1,LU2,IERMS,IUNIT,R,IT,DD1)
      IF(IERMS(1))500,20,500
20    RETURN
500   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
C 
C 
      SUBROUTINE XSVSU(LU1,LU2,IERMS,IUNIT,R,IT,DD1), 
     +09580-16136 REV.2001 791023 
C 
C***********************************************************
C     THIS IS THE SETUP DEVICE SUBROUTINE FOR THE 
C     HP3437A SYSTEM VOLTMETER
C     THE PARAMETERS HAVE THE FOLLOWING MEANING 
C 
C     LU1=LU NUMBER OF HPIB CARD
C     LU2=LU NUMBER OF 3437A
C     IERR IS A 5 WORD ARRAY WITH IERR(1)= ERROR CODE  WHERE: 
C 
C 
C                       0=NO ERROR
C                       1= PARAMETER ERROR
C 
C     ERROR MESSAGES WHICH PERTAIN TO THE HPIB
C 
C     9= I/O CALL REJECTED
C     10= LU1 OR LU2 NOT ASSIGNED 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         R=VOLTAGE RANGE 
C             .1 VOLT RANGE 
C             1  VOLT RANGE 
C             10 VOLT RANGE 
C 
C 
C        IT=TRIGGER SOURCE
C          1=INTERNAL 
C          2=EXTERNAL 
C 
C        DD1= DELAY SETTING 
C             175 MICROSECONDS TO 999999 MICROSECONDS 
C 
C 
C 
C***********************************************************
      DIMENSION IREG(2),IHP(4),IERMS(5) 
      DIMENSION IRBUF(3),ITBUF(3) 
      DIMENSION IOBUF(10),IEBUF(2)
      DIMENSION ITRBF(2),RNG(3),IBUF(1) 
C 
C 
      EQUIVALENCE (REG,IREG,IAA),(IREG(2),IB) 
      DATA IHP/5,2HHP,2HIB,2H  /
      DATA IRBUF/2HR1,2HR2,2HR3/
      DATA ITBUF/2HT1,2HT2/ 
      DATA RNG/.1,1.0,10.0/ 
      DATA IREN/1600B/
      DATA IEBUF/2HE0/
C 
C 
      ICNWD=0 
      IERMS=0 
      IASCU=30000B
      IASCL=60B 
      IDTN=43 
C 
C 
      IF(R.LT..1.OR.R.GT.10)IERMS=1 
      IF(IT.LT.1.OR.IT.GT.2)IERMS=1 
      IF(DD1.LT.175.OR.DD1.GT.999999.)IERMS=1 
C 
      IF(IERMS.EQ.1)GO TO 9000
C 
      IOL=10
C 
C*****FIND RANGE VALUE****
      DO 200 I=1,3
      IF(R.EQ.RNG(I))GO TO 300
200   CONTINUE
      IERMS=1 
      GO TO 9000
C*****RANGE PARAMETER*****
300   IOBUF(1)=IRBUF(I) 
C 
C 
C*****TRIGGER PARAMETER*****
      IOBUF(2)=ITBUF(IT)
C 
C 
C*****PACKED FORMAT CODE *****
      IOBUF(3)=2HF2 
C 
C 
C*****NO SRQ******* 
      IOBUF(4)=2HE0 
      IOBUF(5)=51454B 
C 
C*****PROCESS DELAY PARAMETER******** 
C 
C*****DELAY PARAMETER CODE= D.XXXXXX0S******* 
      IOBUF(6)=2HD. 
C 
C 
C****FIRST DGT****
      RDD1=(DD1/100000.)
      IDD1=INT(RDD1)
      IX1=(IDD1*2**8)+30000B
      RDD1=IDD1 
C 
C 
C***2ND DGT***
      RDD2=(DD1-(RDD1*100000.))/10000.
      IDD2=INT(RDD2)
      IX2=IDD2+60B
      RDD2=IDD2 
C 
C 
C***SAVE 1ST &2ND DGT***
      IOBUF(7)=IOR(IX1,IX2) 
C 
C 
C***3RD DGT***
      RDD3=(DD1-(RDD1*100000.)-(RDD2*10000.))/1000. 
      IDD3=INT(RDD3)
      IX3=(IDD3*2**8)+30000B
      RDD3=IDD3 
C 
C 
C****4TH DGT****
      RDD4=(DD1-(RDD1*100000.)-(RDD2*10000.)-(RDD3*1000.))/100. 
      IDD4=INT(RDD4)
      IX4=IDD4+60B
      RDD4=IDD4 
C 
      IOBUF(8)=IOR(IX3,IX4) 
C 
C***5TH DGT**** 
      FDD5=(RDD1*100000.)+(RDD2*10000.)+(RDD3*1000.)+(RDD4*100.)
      RDD5=(DD1-FDD5)/10. 
      IDD5=INT(RDD5)
      IX5=(IDD5*2**8)+30000B
      RDD5=IDD5 
C 
C 
C****6TH DGT****
      RDD6=DD1-(FDD5+(RDD5*10.))
      IDD6=INT(RDD6)
      IX6=IDD6+60B
      IOBUF(9)=IOR(IX5,IX6) 
C 
C 
C****ASCII S  (FOR STORE)** 
C 
      IOBUF(10)=2HS 
C 
C 
C**SET BUS TO REMOTE**
      CALL EXEC(100003B,1600B+LU1)
      GOTO 700
C 
400   CALL ABREG(IAA,IB)
      IF(IB.LT.0)GO TO 910
C 
C 
C****OUTPUT ASCII DATA*** 
      CALL EXEC(100002B,LU2,IOBUF,10,IDUMY,0) 
      GO TO 700 
C 
550   CALL ABREG(IAA,IB)
      IF(IB.LT.0)GO TO 910
C 
C 
      RETURN
C 
C 
C*****ERRORS***** 
C 
C 
700   IERMS=9 
      GO TO 9000
C 
910   IERMS=IAND(IREG,377B)+11
9000  IERMS(2)=5
      IERMS(3)=2HDS 
      IERMS(4)=2HVS 
      IERMS(5)=2HU
      RETURN
      END 
      END$
                                                                                                                                                                                                                                      