FTN4,L SUBROUTINE PSPRG(IUNIT,PGVAL),09580-16319 1926 790502 C C------------------------------------- C C HP 59501A POWER SUPPLY PROGRAMMER, D TO A C C RELOCATABLE 09580-16319 C SOURCE 09580-18319 C C BOB RICHARDS 790402 C BOB RICHARDS 790502 C C------------------------------------ C C !=================================================! C ! ! C ! (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979 ! C ! ALL RIGHTS RESERVED ! C ! ! C ! NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, ! C ! REPRODUCED OR TRANSLATED INTO ANOTHER PROGRAM ! C ! LANGUAGE WITHOUT THE PRIOR WRITTEN CONSENT OF ! C ! THE HEWLETT-PACKARD COMPANY. ! C ! ! C !-------------------------------------------------! C ! ! C ! TEST SYSTEM SOURCE SOFTWARE IS THE PROPRIETY ! C ! MATERIAL OF THE HEWLETT-PACKARD COMPANY. ! C ! ! C ! THIS SOURCE DATA SHALL BE USED SOLELY IN ! C ! CONJUCTION WITH ELECTRONIC COMPUTER SYSTEMS ! C ! SUPPLIED TO THE USER BY HEWLETT-PACKARD. ! C ! ! C ! THIS PROPRIETY DATA SHALL NOT BE COPIED OR ! C ! OTHERWISE REPRODUCED WITHOUT THE PRIOR WRITTEN ! C ! CONSENT OF HEWLETT-PACKARD, EXCEPT THAT ONE ! C ! COPY MAY BE MADE AND RETAINED BY THE USER FOR ! C ! ARCHIVE PURPOSES. ! C ! ! C ! THE USER SHALL NOT DISCLOSE THIS DATA TO ANY ! C ! THIRD PARTIES WITHOUT THE PRIOR WRITTEN CONSENT ! C ! OF HEWLETT-PACKARD. IN ADDITION, THE USER SHALL ! C ! USE AT LEAST THE SAME CARE AND SAFEGUARDS TO ! C ! PROTECT THIS DATA FROM UNAUTHORIZED USE OR ! C ! DISCLOSURE AS THE USER USES TO PROTECT ITS OWN ! C ! PROPRIETARY DATA. ! C ! ! C !=================================================! C C GENERAL: C -------- C C THE FOLLOWING DEVICE SUBROUTINES ARE USED C TO PROGRAM THE HP 59501A PROGRAMMABLE SIGNAL SOURCE. C C HARDWARE REQUIRED: C ------------------ C A. HP 59501A C B. HP59310 BUSS INTERFACE KIT. C C JUMPER POSITION: C SW1-1 - 1 C SW1-2 TO SW1-8 - 0 C SW2-1 - 0 C SW2-2 - 0 C SW2-3 - 0 C SW2-4 - 0 C SW2-5 - 1 C SW2-6 - REN C SW2-7 - ICF C SW2-8 - CNX C C C. HP 21XX SERIES COMPUTER C C BRANCH AND MNEMONIC TABLE ENTRIES: C ---------------------------------- C C PSPRG(I,R), OV=XX, ENT=PSPRG, FIL=%PSPRG C C CONFIGURATION TABLE ENTRIES: C ---------------------------- C C R 58,1,19 C U1 C C 00.00 TEMPORARY STORAGE FOR VOLTAGE C 00.00 TEMPORARY STORAGE FOR CURRENT C 00.00 V MAX C 00.00 V MIN C 00.00 I MAX C 00.00 I MIN C FF.FF NOT USED C FF.FF NOT USED C NN NUMBER OF UNITS C N CURRENT/VOLTAGE SOURCE 0=I, 1=V C N HI RANGE/LOW RANGE 0=LOW, 1=HIGH C C C C NOTE: WHEN ENTERING VALUES FOR VMAX AND IMAX, SET THEM C TO 99.9% OF THE DESIRED MAX. FOR EXAMPLE, A 20 VOLT MAX C POWER SUPPLY SHOULD HAVE VMAX = .999 * 20.0 = 19.98 VOLTS. C C C C------------------------------------ C C PSPRG(IUNIT,PGVAL) C C WHERE: C C IUNIT = UNIT # C C PGVAL = PROGRAMMED CURRENT OR VOLTAGE VALUE C C C C------------------------------------ DIMENSION IERMS(5) DATA IDTN / 58 / DATA IERMS / 10,5,2HPS,2HPR,2HG / C IERMS=10 C C FIND STATION AND LU #'S C ISTN = STATION # C LU1 = HP 59501A LU C LUIB = HPIB LU C ISTN=ISN(DUMMY) LU1=LUDV(ISTN,IDTN,IUNIT) LUIB=IBLU0(LU1) IF(LU1 .LE. 0 .OR. LUIB .LE. 0)GOTO 800 C C CALL X SUB C CALL XSPRG(LU1,LUIB,IERMS,IUNIT,PGVAL) IF(IERMS)800,20,800 C C EXIT C 20 RETURN C C ERROR EXIT C 800 CALL ERROR(IERMS,IERMS(2)) RETURN END C C--------------------------------------------- C SUBROUTINE XSPRG(LU1,LUIB,IERMS,IUNIT,PGVAL), +09580-16319 1926 790502 DIMENSION IERMS(5),IBUF(19),IOBUF(2),IFS(6),IREG(2) EQUIVALENCE (REG,IREG,IA),(IREG(2),IB) EQUIVALENCE (IBUF(18),IFGCV) EQUIVALENCE (IBUF(5),VMAX) EQUIVALENCE (IBUF(7),VMIN) EQUIVALENCE (IBUF(9),CMAX) EQUIVALENCE (IBUF(11),CMIN) EQUIVALENCE (IBUF(17),NUNIT) EQUIVALENCE (IBUF(19),LOWHI) C INUM = 2 C--------------------------------------------- C C C THE PARAMETERS IN THE CALLING SEGUENCE HAVE THE FOLLOWING C MEANINGS. C C LUIB = LU # OF HPIB BUSS. C LU1 = LU # OF HP 59501A C C IERMS IS A FIVE WORD ARRAY WITH IERR(1) CONTAINING C THE ERROR CODE. C C 0 = NO ERROR C 1 = PARAMETER ERROR C C ERROR MESSAGES THAT PERTAIN TO THE HPIB. C C 9 = I/O CALL REJECTED C 10 = LUIB OR LU1 = 0 C 12 = I/O DEVICE TIME OUT C 13 = IFC DETECTED DURING I/O REQUEST C 14 = SRQ ABORTED C 15 = NON-EXISTENT ALARM PROGRAM C 16 = ILLEGAL CONTROL REQUEST C 17 = EQT EXTENSION AREA FULL C C IERMS(2) = ERROR MNEMONIC CHARACTER COUNT C IERMS(3) TO IERMS(5) = ERROR MNEMONIC C C C--------------------------------------------- C C C RETRIEVE CONFIGURATION DATA C CALL TIM(58,IUNIT,1,IBUF,19,IER) IF(IER .NE. 0)RETURN IERMS = 1 C C PRESET UNIPOLAR-BIPOLAR FLAG C IUNBI = 0 IF (IFGCV .EQ. 0) GOTO 200 C C CHECK VOLTAGE SOURCE INPUT PARAMETERS C IF(PGVAL .GT. VMAX ) GOTO 8000 IF(PGVAL .LT. VMIN ) GOTO 8000 IF((VMIN .LT. 0.0) .AND. (VMAX .GT. 0.0)) GOTO 1100 GOTO 1000 C C CHECK CURRENT SOURCE INPUT C 200 IF (PGVAL .GT. CMAX) GOTO 8000 IF (PGVAL .LT. CMIN) GOTO 8000 VMAX = CMAX IF ((CMIN .LT. 0.0) .AND. (CMAX .GT. 0.0)) GOTO 1100 C C SET UP BUFFER FOR UNIPOLAR OUTPUT C 1000 DIV = VMAX/1000.0 GOTO 1200 C C SET BUFFER FOR BIPOLAR OUTPUT C 1100 IUNBI = 1 DIV = VMAX/500.0 C C C 1200 IOBUF(1) = 2H10 IF(LOWHI .EQ. 1) IOBUF(1) = 2H20 OUTPT = (PGVAL/DIV) + 0.5 IF (IUNBI .EQ. 1) OUTPT = OUTPT + 500.0 IF (OUTPT .GT. 999.0) OUTPT = 999.0 CALL FXF2A(OUTPT,IFS) IFS(3) =IAND(IFS(3),377B) IOBUF(1) = IOBUF(1) + IFS(3) - 60B IOBUF(2) = IFS(4) C C REMOTE ENABLE C 2000 CALL EXEC(100003B,1600B+LUIB) GOTO 9000 70 CALL ABREG(IA,IB) IF(IB .LT. 0) GOTO 8500 C C SEND OUTPUT BUFFER C CALL REIO(100002B,LU1,IOBUF(1),INUM,IDUMY,0) GOTO 9000 71 CALL ABREG(IA,IB) IF(IB .LT. 0) GOTO 8500 C C C UPDATE COMMON DATA C IF(IFGCV .EQ. 0) IBUF(3) = PGVAL IF(IFGCV .EQ. 1) IBUF(2) = PGVAL CALL TIM(58,IUNIT,2,IBUF,19,IER) IF (IER .NE. 0) RETURN C IERMS=0 RETURN C C ERROR EXIT C 8500 IERMS=IAND(IA,377B)+11 GOTO 8000 9000 IERMS=9 8000 IERMS(2)=5 IERMS(3)=2HPS IERMS(4)=2HPR IERMS(5)=2HG RETURN END C C SUBROUTINE FXF2A(FNUM,IFS),09580-16319 1926 790502 C C C ON ENTRY, FNUM CONTAINS A FLOATING POINT NUMBER IN THE C THE RANGE 0.0 - 999999.0 (ANY F.P. FORMAT ACCEPTABLE TO C SUBROUTINE "F2A"). THE NUMBER MUST BE POSITIVE. C C ON RETURN, IFS(2-4) CONTAINS PACKED ASCII WITH LEADING C ZEROES, NO DECIMAL POINT, NO "E". IFS(5-6) CONTAINS C ASCII BLANKS (20040B). C C IFS(1) = -1 (INTEGER FORMAT) FOR ERROR RETURN. C C C DIMENSION IFS(6),JFS(10) C C C IF (FNUM .GE. 0.0 .OR. FNUM .LT. 1E6) GO TO 10 IFS(1) = -1 RETURN C C C 10 DO 100 I=1,6 IFS(I) = 20040B 100 CONTINUE C C CONVERT TO ASCII C C CALL F2A(FNUM,IFS(1)) IF(IAND(IFS(2),177400B) .NE. 37400B) GO TO 110 IFS(1) = -1 RETURN C C FIND "E" IF PRESENT C 110 IEFLG = 0 DO 150 I=2,6 IF (IAND(IFS(I),177400B) .EQ. 42400B) GO TO 130 IF (IAND(IFS(I),377B) .EQ. 105B) GO TO 120 GO TO 150 120 IENUM = (IAND(IFS(I+1),177400B))/256 GO TO 140 130 IF (I .EQ. 2) IEFLG = 1 IENUM = IAND(IFS(I),377B) 140 IENUM = IENUM - 60B GO TO 160 150 CONTINUE IENUM = 0 C C IENUM CONTAINS INTEGER VALUE OF "E" (0-6). C NOW UNPACK CHARACTERS. C 160 DO 200 I=1,5 N=(I*2)-1 JFS(N) = (IAND(IFS(I+1),177400B))/256 JFS(N) = IAND(JFS(N),377B) JFS(N+1) = IAND(IFS(I+1),377B) 200 CONTINUE IF (IEFLG .NE. 1) GO TO 210 JFS(1) = 61B JFS(2) = 40B IENUM = IENUM - 1 C C LOCATE THE DECIMAL POINT C 210 DO 220 ID=1,10 IF (JFS(ID) .EQ. 56B .OR. JFS(ID) .EQ. 40B) GO TO 230 IF (JFS(ID) .EQ. 105B) GO TO 225 220 CONTINUE IFS(1) = -1 RETURN C C VALID NUMBER BUT NO DECIMAL POINT C 225 JFS(ID+1) = 60B C C DELETE DECIMAL POINT, ADJUST E VALUE C 230 DO 250 I=ID,9 JFS(I) = JFS(I+1) IF (JFS(I) .EQ. 105B .OR. JFS(I) .EQ.40B) GO TO 240 GO TO 250 240 DO 245 J=I,10 JFS(J) = 60B 245 CONTINUE GO TO 260 250 CONTINUE C C SHIFT CHARACTERS AS NECESSARY C 260 ISHFT = 7 - (ID+IENUM) IF (ISHFT .EQ. 0) GO TO 300 DO 280 I=10,ISHFT+1,-1 JFS(I) = JFS(I-ISHFT) 280 CONTINUE C C ADD LEADING ZEROES C DO 290 I=1,ISHFT JFS(I) = 60B 290 CONTINUE C C PACK CHARACTERS C 300 DO 310 I=1,3 J = (I*2)-1 JFS(J) = JFS(J)*256 JFS(J) = IAND(JFS(J),177400B) JFS(J+1) = IAND(JFS(J+1),377B) IFS(I+1) = JFS(J)+JFS(J+1) 310 CONTINUE C C LOAD TRAILING BLANKS C DO 320 I=5,6 IFS(I) = 20040B 320 CONTINUE C C C RETURN END END$