FTN4,L
      SUBROUTINE DCVSH(UNIT,VOLT,CURLIM),09580-16038 REV.2001 
     +791023
C-------------------------------------------------------------------
C 
C      RELOC.       09580-16038 
C      SOURCE       09580-18038 
C 
C      C. LEATH     03/15/77    REV. A
C      R. UNTALAN   05/15/77    REV. B
C      V.POVIO      780422      REV. C
C      BOB RICHARDS 791023
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-------------------------------------------------------------------
      INTEGER UNIT
      DIMENSION IERMS(5)
      DATA IDTN/22/ 
      DATA IERMS/10,5,2HDC,2HVS,2HH / 
C 
C     INTERFACE MODULE 61XX HIGH OUTPUT DEVICE SUBROUTINE 
C 
C 
      IERMS= 10 
      ISTN = ISN(DUMMY) 
      IU = ((UNIT - 1)/8) + 1 
      LU = LUDV(ISTN,IDTN,IU) 
      IF(LU)800,800,10
10    IF(UNIT .GT. 8)UNIT=UNIT-8
      CALL XCVSH(LU,IERMS,UNIT,VOLT,CURLIM) 
      IF(IERMS)800,20,800 
20    RETURN
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
      SUBROUTINE DCISH(UNIT,CURR,VOLLIM),09580-16038 REV.2001 
     +791023
C-------------------------------------------------------------------
C 
      INTEGER UNIT
      DIMENSION IERMS(5)
      DATA IDTN/22/ 
      DATA IERMS/10,5,2HDC,2HIS,2HH / 
C 
C     INTERFACE MODULE 6140A HIGH CURRENT DEVICE SUBROUTINE 
C 
C 
      IERMS= 10 
      ISTN = ISN(DUMMY) 
      IU = ((UNIT - 1)/8) + 1 
      LU = LUDV(ISTN,IDTN,IU) 
      IF(LU)800,800,10
10    IF(UNIT .GT. 8)UNIT=UNIT-8
      CALL XCVSH(LU,IERMS,UNIT,CURR,VOLLIM) 
      IF(IERMS)800,20,800 
20    RETURN
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
      SUBROUTINE XCVSH(LU,IERR ,UNIT,VI,VILIM), 
     +09580-16038 REV.2001 791023 
C*********************************************************************
C 
C        THIS SUBROUTINE SETS THE DVS/DCS TO THE HIGH V/I RANGE.
C        THE PARAMETERS IN THE CALLING SEQUENCE ARE DEFINED 
C        AS FOLLOWS:
C 
C 
C     LU = LOGICAL UNIT NUMBER FOR INSTRUMENT 
C     IERR = 5 WORD ERROR ARRAY 
C     WHERE IERR(1) = ERROR CODE WITH:
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 = DEVICE NOT ASSIGNED TO STATION OR NONEXISTENT
C           IERR(2) = CHARACTER COUNT 
C           IERR(3) - IERR(4) = DEVICE SUBROUTINE MNEMONICS 
C 
C                   IUNIT IS THE UNIT NUMBER
C                   VI IS THE DESIRED OUTPUT(V OR I)
C                   -50.00<= VI <= 50.00 FOR 6129 AND 6130 (VOLTS)
C                  -100.00<=VI <= 100.00 FOR 6131 (VOLTS) 
C                  -163.84<= VI <= 163.835 FOR 6140A (MA) 
C                   N/A FOR 6128 OR 6933 SINCE THEY HAVE NO HIGH
C                         VOLTAGE RANGE.
C 
C                   VILIM IS THE DESIRED VOLTAGE/CURRENT LIMIT
C 
C 
C          VOLTAGE/CURRENT LIMIT TABLE
C-------------------------------------------------------------- 
C POWER SUPPLIES      6128C     6129C   6130C   6131C   6140A 
C-------------------------------------------------------------- 
C                      (MA)      (MA)    (MA)    (MA)    (V)
C                      250      100      20      20       2 
C                      625      250      50      50       5 
C                      875      350      70      70       7 
C                     1250      500     100     100      10 
C                     2500     1000     200     200      20 
C                     6250     2500     500     500      50 
C                     8750     3500     700      -       70 
C                    12500     5000    1000      -      100 
C-------------------------------------------------------------- 
C 
C*********************************************************************
      INTEGER UNIT, IBUF(2), CL, CLISZ
      INTEGER CONWD, IDBUF1(3), WORD1, WORD2
      INTEGER IDBUF2(3), ICBUF(3), IREG(2)
      INTEGER IERR(5) 
      REAL LIMIT, CLMT(8) 
      EQUIVALENCE (REG,IREG,IA),(IREG(2),IB)
      DATA CLMT/20.,50.,70.,100.,200.,500.,700.,1000./
      DATA ICBL/3/, IDBL/3/, IDBUF1/13,0,0/ 
      DATA ICBUF/4,1,3/ 
C*********************************************************************
C        THE CONFIGURATION TABLE CONTAINS TWO ENTRIES FOR THE 
C        POWER SUPPLIES:
C 
C              IBUF(1)= TYPE OF PWR SUPPLY (6128,6129, ETC.)
C              IBUF(2)= OUTPUT WORD2 WITHOUT THE CURRENT/VOLTAGE LIMIT
C THE FOLLOWING IS AN EXAMPLE OF THE CONFIGURATION TABLE DATA FOR THE 
C 61XX POWER SUPPLIES.
C 
C     R 22,6,2      DEVICE TYPE #,6UNITS,2ENTRIES EACH
C     U1
C       6130
C       0 
C     U2
C       6140
C       0 
C     U3
C       6131
C       0 
C     U4
C     6129
C     0 
C     U5
C     6129
C     0 
C     U6
C       6131
C       0 
C*********************************************************************
C 
C     BRANCH AND MNEMONIC TABLE ENTRIES 
C 
C    DCVSH(I,R,R),      OV=N,     ENT=DCVSH,   FIL=%DCVSH 
C    DCISH(I,R,R),      OV=N,     ENT=DCISH,   FIL=%DCVSH 
C    DCVSL(I,R,R),      OV=N,     ENT=DCVSL,   FIL=%DCVSL 
C    DCISL(I,R,R),      OV=N,     ENT=DCISL,   FIL=%DCVSL 
C    DCV(I,R,R),        OV=N,     ENT=DCV,     FIL=%DCV 
C    DCI(I,R,R),        OV=N,     ENT=DCI,     FIL=%DCV 
C    DCOPL(IVA),        OV=N,     ENT=DCOPL,   FIL=%DCOPL 
C 
C 
C****************************************************************** 
C 
C 
      IERR = 0
      CALL TIM(22,UNIT,1,IBUF,2,N)
      IF(N.NE.0)RETURN
      IERR = 1
C*********************************************************************
C        CHECK IF TYPE IS 6128 OR 6933 WHICH HAVE NO HIGH RANGE 
C*********************************************************************
      IF(IBUF   .EQ.6128.OR.IBUF   .EQ.6933) GO TO 99 
C*********************************************************************
C        SET APPROPRIATE LIMIT
C 
      LIMIT= 50.00001 
      IF(IBUF   .EQ.6131) LIMIT= 100.00001
      IF(IBUF   .EQ.6140) LIMIT= 163.83501
C 
C        SET # OF ENTRIES IN I-LIMIT TABLE
C 
      CLISZ= 8
      IF(IBUF   .EQ.6131) CLISZ= 6
C 
C        DETERMINE APPLICABLE OUTPUT LIMIT TABLE
C 
      DIVFA= 1.0
      IF(IBUF .EQ. 6140) DIVFA = 0.100
      IF(IBUF   .EQ.6129) DIVFA= 5.0
      IF(IBUF   .EQ.6128.OR.IBUF   .EQ.6933) DIVFA= 15.0
C*********************************************************************
C        CHECK IF LIMIT IS EXCEEDED 
C*********************************************************************
      IF(ABS(VI)-LIMIT.GT.0.) GO TO 99
C*********************************************************************
C        SET UP OUTPUT WORD1
C*********************************************************************
      WORD1= IFIX(VI*200.)
C*********************************************************************
C        PROCESS CURRENT LIMIT
C*********************************************************************
      SAVEA= -VILIM/DIVFA 
      IF(SAVEA.GT.0.) GO TO 99
      CL= 0 
 45   IF(CLMT(CL+1) + SAVEA) 50,60
 50   CL= CL+1
C*********************************************************************
C        DOES CURRENT LIMIT EXCEED THE MAXIMUM? 
C*********************************************************************
      IF(CL+1.GT.CLISZ) GO TO 99
      GO TO 45
C*********************************************************************
C        SET UP OUTPUT WORD2, AND OTHER PARAMETERS NEEDED FOR OUTPUT
C*********************************************************************
 60   WORD2= (CL*10B) + (UNIT-1)
      CONWD= 11300B + LU
      IDBUF1(3)= WORD2
      IDBUF2   = 13 
      IDBUF2(2)= WORD1
      IDBUF2(3)= WORD2
C*********************************************************************
C        IS NEW RANGE THE SAME AS PREVIOUS RANGE? 
C*********************************************************************
      IERR = 2
C 
C     DISARM ANY PREVIOUS ALARM PROGRAM.
C 
      CALL EXEC(100003B,400B+LU)
      GO TO 88
69    CALL ABREG(IA,IB) 
      IF(IAND(IREG,377B).NE.0)GO TO 99
      ITST1 = IAND(IBUF(2),177707B) 
      ITEST= IAND(WORD2,177707B)
      IF(ITST1  .NE.ITEST) GO TO 70 
      ITST1 = IAND(IBUF(2),70B) 
      ITEST = IAND(WORD2,70B) 
      IF(ITEST.LE.ITST1)GO TO 75
C*********************************************************************
C        SEND UPDATED BUFFER TO TABLE 
C        ESTABLISH ALARM MODE, SET RANGE, SET OUTPUT TO ZERO
C*********************************************************************
70    CALL EXEC(100002B,CONWD,IDBUF1,IDBL,ICBUF,ICBL) 
      GO TO 88
73    CALL ABREG(IA,IB) 
77    IF(IAND(IREG,377B ).NE.0)GO TO 99 
C 
C        ESTABLISH ALARM MODE AND SET NEW OUTPUT
      CALL EXEC(100003B,500B+LU)
      GO TO 88
C 
75    CALL EXEC(100002B  ,CONWD,IDBUF2,IDBL,ICBUF,ICBL) 
      GO TO 88
80    IBUF(2) = WORD2 
      CALL TIM(22,UNIT,2,IBUF,2,N)
C 
C 
      IERR = 0
      RETURN
88    IERR = 9
99    IERR(2) = 5 
      IERR(3) = 2HDC
      IERR(4) = 2HVS
      IF (IBUF .EQ. 6140) IERR(4) = 2HIS
      IERR(5) = 2HH 
      RETURN
      END 
      END$
                                                                                                                                                                        