FTN4,L
      SUBROUTINE PPGOM(IUNIT,AHIL,ALOL,IEN,ISCHN,IZCHN),
     +09580-16306 1926 790502 
C 
C-------------------------------------
C 
C  HP 8160A PROGRAMMABLE SIGNAL SOURCE
C      (PPGOM)
C 
C  RELOCATABLE 09580-16306
C  SOURCE      09580-18306
C 
C  R.UNTALAN           REV. 1840
C  R.UNTALAN           REV. 1926
C  BOB RICHARDS 790502
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 8160A PROGRAMMABLE PULSE GENERATOR
C 
C  HARDWARE REQUIRED: 
C  ------------------ 
C    A. HP 8160A  PROGRAMMABLE SIGNAL SOURCE. 
C    B. HP59310  BUS 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    PPGOM(I,R,R,I,I,I),  OV=XX,   ENT=PPGOM,   FIL=%PPGOM
C 
C  CONFIGURATION TABLE ENTRIES: 
C  ---------------------------- 
C 
C    R 49,1,11
C    U1 
C       2   NUMBER OF CHANNELS 1=CHAN. A ONLY   2=CHAN A&B
C       0.0    TEMPORARY STORAGE FOR CHAN A LO-LEVEL
C       0.0    TEMPORARY STORAGE FOR CHAN A HI-LEVEL
C       0.0    TEMPORARY STORAGE FOR CHAN B LO-LEVEL
C       0.0    TEMPORARY STORAGE FOR CHAN B HI-LEVEL
C         0    TEMPORARY STORAGE FOR IMPEDANCE
C         0    TEMPORARY STORAGE FOR (A SEP B) OR (A ADD B) 
C 
C 
C 
C 
C------------------------------------ 
C 
C  PPGOM(IUNIT,AHIL,ALOL,IEN,ISCHN,IZCHN) 
C 
C    WHERE: 
C 
C       IUNIT = UNIT #
C 
C       AHIL = HIGH LEVEL AMPLITUDE 
C              -9.89 TO 9.99    WITH 50 OHM IMPEDANCE 
C              -19.7 TO 19.9    WITH 1K OHM IMPEDANCE 
C       ALOL = LOW LEVEL  AMPLITUDE 
C              -9.99 TO 9.89    WITH 50 OHM IMPEDANCE 
C              -19.9 TO 19.7    WITH 1K OHM IMPEDANCE 
C 
C  NOTE: A PARAMETER ERROR WILL RESULT IF ALOL IS GREATER THAN AHIL.
C 
C 
C 
C       IEN  = OUTPUT ENABLE/OUTPUT DISABLE 
C 
C               0 = ENABLE
C               1 = DISABLE 
C 
C       ISCHN = A SEP B * A ADD B 
C               0 = A SEP B 
C               1 = A ADD B 
C 
C       IZCHN = IMPEDANCE*NORM.COMPL.*CHAN
C 
C               0 = 50 OHMS/NORMAL/A CHAN 
C               1 = 1K OHMS/NORMAL/A CHAN 
C               2 = 50 OHMS/COMPLEMENT/A CHAN 
C               3 = 1K OHMS/COMPLEMENT/A CHAN 
C               4 = 50 OHMS/NORMAL/B CHAN 
C               5 = 1K OHMS/NORMAL/B CHAN 
C               6 = 50 OHMS/COMPLEMENT/B CHAN 
C               7 = 1K OHMS/COMPLEMENT/B CHAN 
C 
C 
C------------------------------------ 
      DIMENSION IERMS(5)
      DATA IDTN / 49 /
      DATA IERMS / 10,5,2HPP,2HGO,2HM  /
C 
      IERMS=10
C 
C  FIND STATION AND LU #'S
C   ISTN = STATION #
C   LU1 = HP 8160A LU 
C   LUIB = 59310 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 XPGOM(LU1,LUIB,IERMS,IUNIT,AHIL,ALOL,IEN,ISCHN,IZCHN)
      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 XPGOM(LU1,LUIB,IERMS,IU,AHIL,ALOL,IEN,ISCHN, 
     +IZCHN),09580-16306 1926 790502
C 
      DIMENSION IERMS(5),IBUF(12),IREG(2),IOBUF(18),IPBUF(2)
      DIMENSION IN(3),IS(2),IZ(10),KHSTR(6),KLSTR(6)
      EQUIVALENCE (REG,IREG,IA),(IREG(2),IB),(JSTR,KHSTR),(LSTR,KLSTR)
      EQUIVALENCE (IBUF(2),ALO) 
      EQUIVALENCE (IBUF(4),AHI) 
      EQUIVALENCE (IBUF(6),BLO) 
      EQUIVALENCE (IBUF(8),BHI) 
      DATA IN /2HEN,2HDI /
      DATA IS /2HAS,2HAA /
      DATA IZ /2HA5,2HAN,2HA1,2HAN,2HA5,2HAC,2HA1,2HAC,2H  /
C 
C---------------------------------------------
C 
C 
C  THE PARAMETERS IN THE CALLING SEGUENCE HAVE THE FOLLOWING
C  MEANINGS.
C 
C     LUIB = LU # OF HPIB BUS.
C     LU1  = LU # OF HP8160A
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 
      IBUFL=11
C 
C 
      CALL TIM(49,IU,1,IBUF,IBUFL,IER)
      IF(IER .NE. 0)RETURN
C 
C 
C 
C CHECK PREVIOUS AMPLITUDE ON CHAN A
C 
      IRCL=0
      IFLAG=0 
C 
C 
C 
C 
      IF (IZCHN .GT. 3) GOTO 10 
C 
C 
C 
C 
C 
C 
      IF(ALO .GT. AHIL) IFLAG=1 
      ALO=ALOL
      AHI=AHIL
      GOTO 30 
C 
C 
C  CHECK PREVIOUS CHAN B AMPLITUDE
C 
10    IF(BLO .GT. AHIL) IFLAG=1 
      BLO=ALOL
      BHI=AHIL
C 
C 
C STORE CURRENT AMPLITUDE AND CHAN SELECT MODE SETTING IN TABLE 
C 
30    IBUF(10)=IZCHN
      IBUF(11)=ISCHN
C 
C 
      CALL TIM(49,IU,2,IBUF,IBUFL,IER)
      IF(IER .NE. 0) RETURN 
C 
C 
C 
C CHECK IF CHAN B AVAILABLE 
C 
20    JMAX=INT(4.0*IBUF(1)) 
C 
C 
C 
C  CHECK PARAMETERS 
C 
      IERMS=1 
      INUM=18 
      IZCHN=IZCHN+1 
      ICHN=IZCHN
      ISCHN=ISCHN+1 
      IEN=IEN+1 
C 
C 
C 
      IF(ALOL.GT.AHIL) GOTO 8000
      IF(ISCHN .LT. 1 .OR. ISCHN .GT. 2) GOTO 8000
      IF(IEN .LT. 1 .OR. IEN .GT. 2) GOTO 8000
      IF(IZCHN .LT. 1 .OR. IZCHN .GT. JMAX) GOTO 8000 
C 
C 
      IF((IZCHN/2)*2 .NE. IZCHN) GOTO111
C 
C SET MINIMUM AND MAXIMUM LIMITS FOR 1K OHM IMPEDANCE 
C 
      ALOMX=19.705
      ALOMN=-19.905 
      AHIMX=19.905
      AHIMN=-19.705 
      DIF=ABS(AHIL-ALOL)+.0005
      IF(DIF .GT. AHIMX .OR. DIF .LT. .2001) GOTO 8000
C 
C 
      GOTO 112
C SET MINIMUM AND MAXIMUM LIMITS FOR 50 OHM IM@EDANCE 
C 
C 
111   ALOMX=9.8905
      ALOMN=-9.9905 
      AHIMX=9.9905
      AHIMN=-9.8905 
      DIF=ABS(AHIL-ALOL)+.0005
      IF(DIF .GT. AHIMX .OR. DIF .LT. .1001) GOTO 8000
C 
C 
112   IF(ALOL.LT.ALOMN.OR.ALOL.GT.ALOMX)GOTO 8000 
      IF(AHIL.LT.AHIMN.OR.AHIL.GT.AHIMX)GOTO 8000 
C 
C 
C 
C  CLEAR  BUFFER
C 
      DO 88 L=1,6 
      KLSTR(L)=2H 
88    KHSTR(L)=2H 
C 
C  CONVERT HI-LEVEL AND LO-LEVEL TO ASCII 
C 
      IF(ABS(AHIL).GE..100)GOTO 105 
      CALL ISOL(AHIL,KHSTR(2),KHSTR(3),KHSTR(4))
C 
C 
100   GOTO 106
C 
105   CALL F2A(AHIL,JSTR) 
C 
C 
106   IF(ABS(ALOL).GE..100) GOTO 108
C 
C 
      CALL ISOL(ALOL,KLSTR(2),KLSTR(3),KLSTR(4))
C 
C 
      GOTO 109
C 
C 
108   CALL F2A(ALOL,LSTR) 
C 
C 
C 
C 
C 
C  SET INDEX POINTER FOR IMPEDANCE/NORM.COMPL./CHANNEL OUT
C 
109   IF(IZCHN.GT.4)IZCHN=IZCHN-4 
      INDX=(2*IZCHN)-1
C 
C   CLEAR OUTPUT BUFFER 
C 
      DO 333 I=1,18 
333   IOBUF(I)=2H 
C 
C 
C 
C  SET UP OUTPUT BUFFER 
C 
      IOBUF(1)=IS(ISCHN)
      IOBUF(2)=IN(IEN)
      IOBUF(3)=IZ(INDX) 
      IOBUF(4)=IZ(INDX+1) 
      IOBUF(5)=2HHI 
      IF(ICHN .LE. 4) IOBUF(6)=2HLA 
      IF(ICHN .GT. 4) IOBUF(6)=2HLB 
      IOBUF(8)=KHSTR(2) 
      IOBUF(9)=KHSTR(3) 
      IOBUF(10)=KHSTR(4)
      IOBUF(11)=2HV 
      IOBUF(12)=2HLO
      IF(ICHN .LE. 4) IOBUF(13)=2HLA
      IF(ICHN .GT. 4) IOBUF(13)=2HLB
      IOBUF(15)=KLSTR(2)
      IOBUF(16)=KLSTR(3)
      IOBUF(17)=KLSTR(4)
      IOBUF(18)=IOBUF(11) 
C 
C  CHANGE SIGN IF POSITIVE
C 
      IF(AHIL .GT. 0) IOBUF(7)=2H+
      IF(ALOL .GT. 0) IOBUF(14)=2H+ 
C 
C 
C 
C 
C  IF PREVIOUS HI-LEVEL IS LOWER THAN THE CURRENT LO-LEVEL
C  THEN OUTPUT THE LO-LEVEL FIRST AND HI-LEVEL SECOND.
C 
      IF(IFLAG .EQ. 0) GOTO 510 
C 
C 
      IOBUF(5)=2HLO 
      IF(ICHN .LE. 4) IOBUF(6)=2HLA 
      IF(ICHN .GT. 4) IOBUF(6)=2HLB 
      IOBUF(8)=KLSTR(2) 
      IOBUF(9)=KLSTR(3) 
      IOBUF(10)=KLSTR(4)
      IOBUF(12)=2HHI
      IF(ICHN .LE. 4) IOBUF(13)=2HLA
      IF(ICHN .GT. 4) IOBUF(13)=2HLB
      IOBUF(15)=KHSTR(2)
      IOBUF(16)=KHSTR(3)
      IOBUF(17)=KHSTR(4)
C 
C 
      IF(AHIL .GT. 0) IOBUF(14)=2H+ 
      IF(ALOL .GT. 0) IOBUF(7)=2H+
C 
C 
C CHANGE BUFFER IF CHAN B SELECTED
C 
510   IF(ICHN.LT.5) GOTO 1999 
      IOBUF(3)=IOBUF(3)+400B
      IOBUF(4)=IOBUF(4)+400B
C 
C 
C 
C 
1999  IF(IBUF(1) .EQ. 2) GOTO 2000
C 
C  DO NOT OUTPUT CHAN. INDICATOR
C 
      IOBUF(1)=2H 
      IOBUF(6)=IAND(177400B,IOBUF(6)) 
      IOBUF(13)=IAND(177400B,IOBUF(13)) 
C 
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 
C 
C  SEND OUTPUT BUFFER 
C 
2100  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  RETURN 
C 
C  CLEAR SRQ
C 
      CALL EXEC(100003B,600B+LU1) 
      GOTO 9000 
66    CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
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)=2HPP 
      IERMS(4)=2HGO 
      IERMS(5)=2HM
      RETURN
      END 
C 
C 
C 
C 
C 
C------------------------------------ 
C 
C 
C   THIS SUBROUTINE CONVERTS NUMBERS  WHICH ABSOLUTE VALUE IS <.01
C   INTO AN ASCII STRING (IWD1,IWD2,IWD3) 
C 
C 
C 
      SUBROUTINE ISOL (ANUM,IWD1,IWD2,IWD3),
     +09580-16306 1926 790502 
C 
C 
      TEMP=ANUM 
      ANUM=ABS(ANUM)
C 
C 
C CONVERT DIGITS TO ASCII 
C 
      I2=INT(ANUM*100.) 
      R2=I2 
      IAS2=I2+60B 
      I3=INT(ANUM*1000.01-R2*10.) 
      IAS3=I3+60B 
C 
C 
C CHECK IF ANUM IS NEGATIVE 
C 
      IF(TEMP.LT.0) GOTO 300
C 
C 
      IWD1=2H.0 
      IWD3=2H 
C 
      IF(ANUM.GE..01) GOTO 310
C 
      IWD2=IOR(30000B,IAS3) 
C 
C 
      RETURN
C 
C 
310   IAS2=IAS2*2**8
      IWD2=IOR(IAS2,IAS3) 
C 
C 
      RETURN
C 
C 
C PROCESS NEGATIVE NUMBER 
C 
C 
300   IWD1=2H-. 
      IAS3=IAS3*2**8
      IWD3=IAND(177400B,IAS3) 
C 
C 
      IF(ANUM.GE..01) GOTO 400
C 
C 
      IWD2=2H00 
C 
C 
      RETURN
C 
C 
400   IWD2=IOR(30000B,IAS2) 
C 
C 
      RETURN
C 
C 
      END 
      END$