FTN4,L SUBROUTINE ANASW(IU,ISW,IUD,FMIN,FMAX,DFLG,DFLI), +09580-16466 REV.2026 800212 C C------------------------------------- C C SCHLUMBERGER 1172 FREQUENCY RESPONSE ANALYZER C C RELOCATABLE 09580-16466 C SOURCE 09580-18466 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 ANASW(I,I,I,R,R,R,R), OV=XX, ENT=ANASW, FIL=%ANASW C C CONFIGURATION TABLE ENTRIES: C ---------------------------- C C NONE REQUIRED C C C C C------------------------------------ C C ANASW(IU,ISW,IUD,FMIN,FMAX,DFLG,DFLI) C C WHERE: C C IU = UNIT # C C ISW = SWEEP MODE C 0=LINEAR C 1=LOGARITHMIC C C IUD = SWEEP COMMAND C 0=OFF C 1=HOLD C 2=SWEEP UP C 3=SWEEP DOWN C C FMIN = MINIMUM SWEEP FREQUENCY C RANGE - .0001HZ TO 9999HZ C C FMAX = MAXIMUM SWEEP FREQUENCY C RANGE - .0001HZ TO 9999HZ C C DFLG = DELTA FREQUENCY LOG SWEEP C RANGE - .2 TO 99.99 SWEEPS PER DECADE C - 0 VALID IF ISW = 0 (RETAINS PREVIOUS DATA) C C DFLI = DELTA FREQUENCY LINEAR SWEEP C RANGE - .0001HZ TO 9999HZ (DOWN TO .1E-6 HZ WITH REDUCED C RESOLUTION.) C - 0 VALID IF ISW = 1 (RETAINS PREVIOUS DATA) C C C------------------------------------ C DIMENSION IERMS(5) DATA IDTN / 72 / DATA IERMS / 10,5,2HAN,2HAS,2HW / 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 XNASW(LU1,LUIB,IERMS,IU,ISW,IUD,FMIN,FMAX,DFLG,DFLI) 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 XNASW(LU1,LUIB,IERMS,IU,ISW,IUD,FMIN,FMAX,DFLG,DFLI), +09580-16466 REV.2026 800212 C DIMENSION IERMS(5),IOBUF(6),ITEM(3) C INTEGER T1,T2,AD7,AD8,ADN,ADF,ADGT,ADQM C DATA T1 /52061B/ DATA T2 /52062B/ DATA AD7 /33400B/ DATA AD8 /34000B/ DATA ADN /47000B/ DATA ADF /43000B/ DATA ADGT /37000B/ DATA ADQM /37400B/ 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 IF(ISW.LT.0.OR.ISW.GT.1) GO TO 8000 IF(IUD .LT.0.OR.IUD .GT.3) GOTO 8000 C IF(IUD .LT.2) GOTO 30 X = .0001 Y = 9999.0 IF(FMIN.LT.X.OR.FMIN.GT.Y) GOTO 8000 IF(FMAX.LT.X.OR.FMAX.GT.Y) GOTO 8000 IF(FMIN.GT.FMAX) GOTO 8000 X = .20 Y = 99.99 IF (ISW.EQ.0 .AND. DFLG.EQ.0.0) GOTO 20 IF(DFLG.LT.X.OR.DFLG.GT.Y) GOTO 8000 20 X = .1E-6 Y = 9999.0 IF (ISW.EQ.1 .AND. DFLI.EQ.0.0) GOTO 30 IF(DFLI.LT.X.OR.DFLI.GT.Y) GOTO 8000 C C SET UP I/O BUFFER TO 'STOP' MEASUREMENT MODE C 30 IOBUF(1) = T2 IOBUF(2) = 35460B C C SET UP I/O BUFFER TO OUTPUT SWEEP MODE OR SWEEP COMMAND C IOBUF(3) = T2 IF(ISW.EQ.1) GOTO 40 IOBUF(4) = IOR(AD7,60B) GOTO 50 40 IOBUF(4) = IOR(AD7,64B) 50 IOBUF(5) = T2 IOBUF(6) = IOR(IOR(IUD,60B),AD8) C C REMOTE ENABLE C CALL EXEC(100003B,1600B+LUIB) GOTO 9000 60 CALL ABREG(IA,IB) IF(IB.LT.0) GOTO 8500 C C OUTPUT DATA C CALL EXEC(100002B,LU1,IOBUF,6,IDUMY,0) GOTO 9000 70 CALL ABREG(IA,IB) IF(IB.LT.0) GOTO 8500 C C SETUP IOBUF FOR FMIN/FMAX FREQUENCY DATA C DO 95 IF = 1,2 C C COMPUTE FMIN/FMAX EXPONENT C DO 75 ICNT = 0,7 IF (IF.EQ.1 .AND. FMIN .LT. (10.**(ICNT-3))) GOTO 80 IF (IF.EQ.2 .AND. FMAX .LT. (10.**(ICNT-3))) GOTO 80 75 CONTINUE 80 IE = ICNT C C CONVERT FMIN/FMAX MAGNITUDE TO ASCII DATA C IF(IF.EQ.1) TEMP = FMIN*(10.**(4-IE)) * 1000. IF(IF.EQ.2) TEMP = FMAX*(10.**(4-IE)) * 1000. TEMP = TEMP + .5 IX = INT(TEMP) CALL CNUMD(IX,ITEM) CALL SHFTB(ITEM,IX) IOBUF(1) = T1 IF(IF.EQ.1) IOBUF(2) = IOR(ADN,ITEM(1)) IF(IF.EQ.2) IOBUF(2) = IOR(ADF,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 FMIN/FMAX DATA C C FORMAT = "T1NMXXX000E" - FMIN C FORMAT = "T1FMXXX000E" - FMAX C CALL EXEC(100002B,LU1,IOBUF,-11,IDUMY,0) GOTO 9000 90 CALL ABREG(IA,IB) IF(IB.LT.0) GOTO 8500 95 CONTINUE C C SETUP I/O BUFFER FOR DELTA F LOG C IF (DFLG .EQ. 0.0) GOTO 105 TEMP = DFLG*100.0 IX = INT(TEMP) CALL CNUMD(IX,ITEM) C C FAKE OUT 'SHFTB' C IZ = 9999 CALL SHFTB(ITEM,IZ) IOBUF(1) = T1 IOBUF(2) = IOR(ADQM,ITEM(1)) IOBUF(3) = ITEM(2) IOBUF(4) = ITEM(3) IOBUF(5) = 2H00 IOBUF(6) = 1H0 C C OUTPUT DELTA F LOG DATA C C FORMAT = "T1?XXXX0000" C CALL EXEC(100002B,LU1,IOBUF,-11,IDUMY,0) GOTO 9000 100 CALL ABREG(IA,IB) IF (IB.LT.0) GOTO 8500 C C SET UP I/O BUFFER FOR DELTA F LINEAR C C COMPUTE DFLI EXPONENT C 105 IF (DFLI .EQ. 0.0) GOTO 7000 DO 110 ICNT = 0,7 IF (DFLI .LT. (10.**(ICNT-3))) GOTO 115 110 CONTINUE 115 IE = ICNT C C CONVERT DFLI MAGNITUDE TO ASCII CODE C TEMP = DFLI*(10.**(4-IE)) * 1000.0 TEMP = TEMP + .5 IX = INT(TEMP) CALL CNUMD(IX,ITEM) IZ = IX C C FAKE OUT 'SHFTB' AS NECESSARY C IF (DFLI .LT. .0001) IZ = 9999 CALL SHFTB(ITEM,IZ) IOBUF(1) = T1 ITEM(1) = IAND(ITEM(1),377B) IOBUF(2) = IOR(ADGT,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 C SEND OUTPUT BUFFER C C FORMAT = "T1>XXXX000E" C CALL EXEC (100002B,LU1,IOBUF(1),-11,IDUMY,0) GO TO 9000 130 CALL ABREG(IA,IB) IF (IB .LT. 0) GO TO 8500 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)=2HAS IERMS(5)=2HW RETURN END C C SUBROUTINE SHFTB(IBUF,IDIGT),09580-16466 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$