FTN4,L
      SUBROUTINE ANAGN(IU,AMP,BIAV,IWA,FREQ), 
     +09580-16465 REV.2026 800212 
C 
C-------------------------------------
C 
C  SCHLUMBERGER 1172 FREQUENCY RESPONSE ANALYZER
C 
C  RELOCATABLE 09580-16465
C  SOURCE      09580-18465
C 
C  BOB RICHARDS  800212 
C 
C------------------------------------ 
C 
C  !=================================================!
C  !                                                 !
C  ! (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980      !
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 PROPRIETARY  !
C  ! MATERIAL OF THE HEWLETT-PACKARD COMPANY.        !
C  !                                                 !
C  ! THIS SOURCE DATA SHALL BE USED SOLELY IN        !
C  ! CONJUNCTION WITH ELECTRONIC COMPUTER SYSTEMS    !
C  ! SUPPLIED TO THE USER BY HEWLETT-PACKARD.        !
C  !                                                 !
C  ! THIS PROPRIETARY 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 SCHLUMBERGER 1172 FREQUENCY RESPONSE ANALYZER. 
C 
C  HARDWARE REQUIRED: 
C  ------------------ 
C    A. SCHLUMBERGER 1172 
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    ANAGN(I,R,R,I,R),    OV=XX,   ENT=ANAGN,   FIL=%ANAGN
C 
C  CONFIGURATION TABLE ENTRIES: 
C  ---------------------------- 
C 
C    NONE REQUIRED
C 
C 
C 
C 
C------------------------------------ 
C 
C  ANAGN(IU,AMP,BIAV,IWA,FREQ)
C 
C    WHERE: 
C 
C       IU   = UNIT # 
C 
C       AMP  = OPERATING AND DISPLAYED VOLTAGE
C              .01 TO 9.99 VOLTS - OPERATING
C              .010 TO 9.999 VOLTS - DISPLAYED
C 
C       BIAV = BIAS VOLTAGE 
C              -9.99 TO 9.99 VOLTS
C              10 MV RESOLUTION 
C 
C       IWA  = WAVEFORM OUTPUT
C              0=TRIANGLE 
C              1=SINE 
C              2=SQUARE 
C 
C       FREQ = OPERATING AND DISPLAYED FREQUENCIES
C              .0001HZ TO 9999.0HZ
C 
C 
C 
C------------------------------------ 
C 
      DIMENSION IERMS(5)
      DATA IDTN / 72 /
      DATA IERMS / 10,5,2HAN,2HAG,2HN  /
C 
      IERMS=10
C 
C  FIND STATION AND LU #'S
C   ISTN = STATION #
C   LU1 = SCHLUMBERGER 1172 LU
C   LUIB = HPIB LU
C 
      ISTN=ISN(DUMMY) 
      LU1=LUDV(ISTN,IDTN,IU)
      LUIB=IBLU0(LU1) 
      IF(LU1 .LE. 0 .OR. LUIB .LE. 0)GOTO 800 
C 
C  CALL X SUB 
C 
      CALL XNAGN(LU1,LUIB,IERMS,IU,AMP,BIAV,IWA,FREQ) 
      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 XNAGN(LU1,LUIB,IERMS,IU,AMP,BIAV,IWA,FREQ),
     +09580-16465 REV.2026 800212 
      DIMENSION IERMS(5),IOBUF(6),ITEM(3) 
C 
      INTEGER T1,T2,ADC,ADG,AD3,AD4,AD6,AD7 
C 
      DATA T1   /52061B/
      DATA T2   /52062B/
      DATA ADC  /41400B/
      DATA ADG  /43400B/
      DATA AD3  /31400B/
      DATA AD4  /32000B/
      DATA AD6  /33000B/
      DATA AD7  /33400B/
C 
C 
C---------------------------------------------
C 
C 
C  THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING
C  MEANINGS.
C 
C     LUIB = LU # OF HPIB BUS.
C     LU1  = LU # OF SCHLUMBERGER 1172
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 
C  CHECK PARAMETERS 
C 
      IERMS=1 
C 
      X = .01 
      Y = 9.99
      Z = -9.99 
      IF(AMP.LT.X.OR.AMP.GT.Y) GO TO 8000 
      IF(BIAV.LT.Z.OR.BIAV.GT.Y) GOTO 8000
      IF(IWA.LT.0.OR.IWA.GT.2) GOTO 8000
      X = .0001 
      Y = 9999.0
      IF(FREQ.LT.X.OR.FREQ.GT.Y) GOTO 8000
C 
C  MEASUREMENT MODE TO 'STOP' 
C 
      IOBUF(1) = T2 
      IOBUF(2) = 35460B 
C 
C  REMOTE ENABLE
C 
      CALL EXEC(100003B,1600B+LUIB) 
      GOTO 9000 
30    CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
C 
C  SEND OUTPUT BUFFER 
C 
C  FORMAT = "T2SEMICOLON0"
C 
      CALL EXEC(100002B,LU1,IOBUF,2,IDUMY,0)
      GOTO 9000 
40    CALL ABREG(IA,IB) 
      IF (IB .LT. 0) GOTO 8500
C 
C  SET UP IOBUF FOR OUTPUT VOLTAGE DATA 
C 
C    COMPUTE EXPONENT OF OUTPUT VOLTAGE DATA
      IF(AMP .LE. .09999) IE = 1
      IF(AMP .GT. .09999 .AND. AMP .LE. .99999) IE = 2
      IF(AMP .GT. .99999) IE = 3
C 
      IF (IE .EQ. 1) TEMP = AMP*10000.0 
      IF (IE .EQ. 2) TEMP = AMP*1000.0
      IF (IE .EQ. 3) TEMP = AMP*100.0 
      TEMP = TEMP+.5
C 
C    CONVERT OUTPUT VOLTAGE MAGNITUDE TO ASCII CODE 
C 
      IX = INT(TEMP)
      CALL CNUMD(IX,ITEM) 
C 
      IOBUF(1) = T1 
      IOBUF(2) = 2HG0 
      IF ((IAND(ITEM(2),377B)).EQ.40B) ITEM(2) = ITEM(2) + 20B
      IOBUF(3) = ((IAND(ITEM(2),377B))*400B) + ((IAND(ITEM(3),
     +177400B))/400B) 
      IOBUF(4) = ((IAND(ITEM(3),377B))*400B) + 60B
      IOBUF(5) = 2H00 
      IOBUF(6) = (60B + IE) * 400B
C 
C  SEND OUTPUT BUFFER 
C 
      CALL EXEC (100002B,LU1,IOBUF,-11,IDUMY,0) 
      GO TO 9000
50    CALL ABREG(IA,IB) 
      IF (IB .LT. 0) GO TO 8500 
C 
C  CONVERT DISPLAY VOLTAGE TO ASCII CODE
C 
      IF (AMP .GE. 1.0) GOTO 60 
      TEMP = AMP * 10000.0
      GOTO 70 
60    TEMP = AMP * 100.0
70    TEMP = TEMP + .5
      IX = INT(TEMP)
      CALL CNUMD(IX,ITEM) 
      IOBUF(1) = T1 
      IF(AMP .GT. 1.0) GOTO 75
      IOBUF(2) = 2H30 
      ITEMP = IAND(ITEM(2),177400B) 
      IF (ITEMP .EQ. 20000B) ITEM(2) = ITEM(2) + 10000B 
      IOBUF(3) = ITEM(2)
      IOBUF(4) = ITEM(3)
      GOTO 78 
75    IOBUF(2) = (IAND(ITEM(2),377B)) + AD3 
      IOBUF(3) = ITEM(3)
      IOBUF(4) = 2H00 
78    IOBUF(5) = 2H00 
      IOBUF(6) = 1H0
C 
C  OUTPUT DISPLAY VOLTAGE 
C 
C    FORMAT = "T13PXXQ0000" 
C 
C 
C  OUTPUT DATA
C 
      CALL EXEC(100002B,LU1,IOBUF,-11,IDUMY,0)
      GOTO 9000 
80    CALL ABREG(IA,IB) 
      IF(IB.LT.0) GOTO 8500 
C 
C  CONVERT BIAS TO ASCII CODE 
C 
      TEMP = (ABS(BIAV)) * 1000.0 
      TEMP = TEMP + 0.5 
      IX = INT(TEMP)
      CALL CNUMD(IX,ITEM) 
C 
C    SET UP IOBUF 
C 
      IOBUF(1) = T1 
      IOBUF(2) = 2HC0 
      IOBUF(3) = ITEM(2)
      IOBUF(4) = ITEM(3)
      IOBUF(5) = 2H0+ 
      IF (BIAV .LT. 0.0) IOBUF(5) = 2H0-
      IOBUF(6) = 1H0
C 
C  OUTPUT DATA
C 
C    FORMAT = "T1C0XXX00S0" 
C 
      CALL EXEC(100002B,LU1,IOBUF,-11,IDUMY,0)
      GOTO 9000 
90    CALL ABREG(IA,IB) 
      IF(IB.LT.0) GOTO 8500 
C 
C  SELECT OUTPUT WAVEFORM 
C 
      IOBUF(1) = T2 
      IOBUF(2) = 2H40 + IWA 
C 
C  OUTPUT DATA
C 
      CALL EXEC(100002B,LU1,IOBUF,2,IDUMY,0)
      GOTO 9000 
100   CALL ABREG(IA,IB) 
      IF(IB.LT.0) GOTO 8500 
C 
C  SET UP OUTPUT BUFFER FOR OPERATING FREQUENCY DATA
C 
      DO 105 ICNT = 0,7 
      IF(FREQ .LT. (10.**(ICNT-3))) GOTO 108
105   CONTINUE
108   IE = ICNT 
      TEMP = FREQ*(10.**(4-IE)) * 1000.0
      TEMP = TEMP + 0.5 
      IX = INT(TEMP)
      CALL CNUMD(IX,ITEM) 
      CALL SHFT(ITEM,IX)
      IOBUF(1) = T1 
      IOBUF(2) = IOR(AD7,ITEM(1)) 
      IOBUF(3) = ITEM(2)
      IOBUF(4) = ITEM(3)
      IOBUF(5) = 2H00 
      IE = IE * 10
      CALL CNUMD(IE,ITEM) 
      IOBUF(6) = ITEM(3)
      IF (IE .EQ. 0) IOBUF(6) = 30000B
C 
C  OUTPUT DATA
C 
C   FORMAT = "T17MXXX000E"
C 
      CALL EXEC(100002B,LU1,IOBUF,-11,IDUMY,0)
      GOTO 9000 
110   CALL ABREG(IA,IB) 
      IF(IB.LT.0) GOTO 8500 
C 
C  SET UP DISPLAYED FREQUENCY 
C 
      IOBUF(2) = (IAND(IOBUF(2),377B)) + AD6
C 
C    THE REST OF IOBUF IS THE SAME AS FOR OPERATING FREQUENCY 
C 
C 
C  OUTPUT DATA
C 
C   FORMAT = "T16MXXX000E"
C 
      CALL EXEC(100002B,LU1,IOBUF,-11,IDUMY,0)
      GOTO 9000 
120   CALL ABREG(IA,IB) 
      IF(IB.LT.0) GOTO 8500 
C 
C 
C  RETURN 
C 
7000  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)=2HAN 
      IERMS(4)=2HAG 
      IERMS(5)=2HN
      RETURN
      END 
C 
C 
      SUBROUTINE SHFT(IBUF,IDIGT),09580-16465 REV.2026 800212 
C 
C  THIS SUBROUTINE SHIFTS THE OUTPUT FROM 'CNUMD' SO THAT THE MOST
C  SIGNIFICANT DIGIT IS ALWAYS IN THE LOWER EIGHT BITS OF IBUF(1).
C 
      DIMENSION IBUF(3) 
C 
      IF (IDIGT.LT.0.OR.IDIGT.GT.9999) IBUF(1) = -1 
      IF (IDIGT.LT.0.OR.IDIGT.GT.9999) RETURN 
C 
C  REPLACE IMBEDDED BLANKS WITH ZEROES
C 
      DO 50 L=1,3 
      IF ((IAND(IBUF(L),177400B)).EQ.20000B) IBUF(L) = IBUF(L) + 10000B 
      IF ((IAND(IBUF(L),377B)).EQ.40B) IBUF(L) = IBUF(L) + 20B
50    CONTINUE
C 
      IF (IDIGT.GE.10) GOTO 75
      IBUF(1) = IBUF(3) 
      IBUF(2) = 2H00
      IBUF(3) = 2H00
      GOTO 1000 
75    IF (IDIGT.GE.100) GOTO 80 
      IBUF(1) = (IAND(IBUF(3),177400B))/400B
      IBUF(2) = (IAND(IBUF(3),377B)*400B) + 60B 
      IBUF(3) = 2H00
      GOTO 1000 
80    IF(IDIGT.GE.1000) GOTO 85 
      IBUF(1) = IBUF(2) 
      IBUF(2) = IBUF(3) 
      IBUF(3) = 2H00
      GOTO 1000 
85    IBUF(1) = (IAND(IBUF(2),177400B))/400B
      IBUF(2) = (IAND(IBUF(2),377B)*400B) + (IBUF(3)/400B)
      IBUF(3) = ((IAND(IBUF(3),377B))*400B) + 60B 
C 
1000  RETURN
      END 
      END$
                                                                                                                              