FTN4,L SUBROUTINE C45OF(IUNIT,IOFSET,OFMHZ,OFHZ), +09580-16462 REV.2026 800130 C C ------------------------------------------------------------ C THIS DEVICE SUBROUTINE SETS UP THE HP5355A C AUTOMATIC FREQUENCY CONVERTER OFFSET FREQUENCY C ENTRY FUNCTIONS. C C A CALL TO THIS DEVICE SUBROUTINE MUST BE PRECEEDED BY A CALL C TO C45SU, TO SET UP THE ASSOCIATED HP 5345A ELECTRONIC COUNTER C AND A CALL TO C45HF TO SET UP ALL OTHER HP 5355A AUTOMATIC C FREQUENCY CONVERTER FUNCTIONS. C ------------------------------------------------------------ C C------------------------------------------------------------- C C RELOC. 09580-16462 C SOURCE 09580-18462 C C R.WRAY 800130 C C TEST SYSTEM SOURCE SOFTWARE IS THE PROPRIETARY C MATERIAL OF THE HEWLETT PACKARD COMPANY. C C (C) COPYRIGHT HEWLETT PACKARD COMPANY 1980. C ALL RIGHTS RESERVED. NO PART OF THIS PROGRAM C MAY BE PHOTOCOPIED, REPRODUCED, OR TRANSLATED TO C ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN C CONSENT OF THE HEWLETT PACKARD COMPANY. C C------------------------------------------------------------- C C BRANCH AND MNEMONIC TABLES ENTRIES: C ---------------------------------- C C C45OF(I,I,R,R) OV=XX, ENT=C45OF, FIL=%C45OF C C CONFIGURATION TABLE DATA: C ------------------------ C C NO ENTRY REQUIRED C C--------------------------------------------------------------- C C ------------------------------------------------- C SET DIMENSIONS AND DATA FOR IERMS (ERROR MESSAGE) C ------------------------------------------------- C DIMENSION IERMS(5) DATA IERMS/10,5,2HC4,2H5O,2HF / C C C ----------------------------------- C SET DEVICE TYPE NUMBER FOR HP 5355A C ----------------------------------- C DATA IDTN/71/ C C C ---------- C ERROR CHECK C ----------- C IERMS = 10 C C C ------------------ C GET STATION NUMBER C ------------------ C ISTN = ISN(DUMMY) C C C ------------------------ C GET LU NUMBER OF HP5355A C ------------------------ C LU1 = LUDV(ISTN,IDTN,IUNIT) C C C ----------------------------------------- C GET LU NUMBER OF HP-IB I/O INTERFACE CARD C ----------------------------------------- C LU0 = IBLU0(LU1) C C C ---------- C ERROR CHECK C ----------- C IF(LU1.LE.0.OR.LU0.LE.0)GO TO 800 C C C ----------------------------------- C CALL MAIN BODY OF DEVICE SUBROUTINE C ----------------------------------- C 10 CALL X45OF(LU0,LU1,IERMS,IUNIT,IOFSET,OFMHZ,OFHZ) C C C ----------- C ERROR CHECK C ----------- C IF(IERMS)800,20,800 C 20 RETURN C C 800 CALL ERROR(IERMS,IERMS(2)) RETURN END C SUBROUTINE X45OF(LU0,LU1,IERMS,IUNIT,IOFSET,OFMHZ, +OFHZ), 09580-16462 REV.2026 800130 C C C ------------------------------------------------------ C CALL X45OF(LU0,LU1,IERMS,IUNIT,IOFSET,OFMHZ,OFHZ) C ------------------------------------------------------ C WHERE: C LU0 = LU NUMBER OF HP-IB I/O INTERFACE CARD C LU1 = LU NUMBER OF HP5355A AUTO FREQ CONVERTER C C IERMS = 5-ELEMENT INTEGER ARRAY, IN WHICH C IERMS(1) = ERROR CODE: C 0 = NO ERROR C 1 = PARAMETER ERROR C C ERROR MESSAGES THAT PERTAIN TO THE HP-IB: C C 9 = I/O CALL REJECTED C 10 = LU NO. NOT ASSIGNED TO HP-IB DEVICE C OR TO STATION C 11 = DMA INPUT REQUEST PREMATURELY C TERMINATED C 12 = I/O DEVICE TIME OUT C 13 = IFC (INTERFACE CLEAR) DETECTED C DURING I/O REQUEST C 14 = SRQ SERVICE ABORTED C 15 = NON-EXISTENT ALARM PROGRAM C 16 = ILLEGAL CONTROL REQUEST C 17 = EQT EXTENSION AREA FULL,NO NEW C DEVICE MAY BE ADDED ON LINE C C IERMS(2) = CHARACTER COUNT OF MNEMONIC NAME C IERMS(3-5) = PACKED ASCII OF MNEMONIC NAME IF C IERMS(1) > 0 C IUNIT = UNIT NUMBER OF HP5355A (MUST BE SAME C AS UNIT NUMBER OF ASSOCIATED HP 5345A) C C IOFSET = OFFSET FREQUENCY ENTRY MODE C 0 = NO OFFSET C 1 = APPLY OFFSET FREQUENCY C C OFMHZ = OFFSET FREQUENCY ENTRY - MEGAHERTZ C -26500 TO 00000 TO +26500(REF NOTES C 1 AND 2 BELOW) C C OFHZ = OFFSET FREQUENCY ENTRY, +- HERTZ C 000000 TO 999999 C C C NOTES: 1. OFFSET FREQUENCY ENTERED MAY BE EITHER POSITIVE C OR NEGATIVE. THE FREQUENCY READ AND DISPLAYED C WILL BE THE ACTUAL MEASURED FREQUENCY PLUS OR C MINUS THE OFFSET FREQUENCY ENTERED BY THIS DEVICE C SUBROUTINE. C C 2. EACH OF THE OFFSET FREQUENCY PARAMETERS MUST BE C PROGRAMMED BY ENTERING ASCII NUMBERS. FOR EXAMPLE, C TO PROGRAM AN OFFSET IN THE MEGAHERTZ RANGE, THE C 'OFMHZ' PARAMETER WOULD BE ENTERED USING ANY C DESIRED FREQUENCY IN THE RANGE OF -26500 TO +26500. C TRAILING ZEROS ARE REQUIRED, BUT LEADING ZEROS C ARE NOT REQUIRED. IF A NEGATIVE OFFSET IS REQUIRED, C THE ENTERED NUMBER MUST BE PREFIXED BY A MINUS(-) C SIGN. A PLUS (+) SIGN NEED NOT BE USED TO INDICATE C POSITIVE OFFSET. IF NO OFFSET IN THE MHZ RANGE IS C REQUIRED, A ZERO (0) IS ENTERED FOR 'OFMHZ'. C C ANY OFFSET FROM -999999 TO +999999 HZ MAY BE PRO- C GRAMMED BY ENTERING A NUMBER FOR THE OFMHZ C PARAMETER AND THEN THE DESIRED NUMBER FOR THE C OFHZ PARAMETER. NEITHER LEADING ZEROS NOR THE C PLUS SIGN (+) IS REQUIRED. AS IN THE OFMHZ PARA- C METER, A MINUS (-) PREFIX IS REQUIRED FOR A NEG- C ATIVE OFFSET (ONLY IF 'OFMHZ' = 0), AND TRAILING C ZEROS ARE REQUIRED. C ---------------- C PROGRAM CODE SET C ---------------- C C PROGRAM C FUNCTION CODE C -------- ------- C C IOFSET =0 = OT0 C =1 = OT1 C C OFMHZ) C OFHZ) = OF [FLOATING POINT] C C C ---------------- C DIMENSION ARRAYS C ---------------- C DIMENSION IERMS(5),IREG(2) DIMENSION NMBR(6),IBUFR(21),IAR(6) EQUIVALENCE(REG,IREG,IA),(IREG(2),IB) C C --------------------- C INITIALIZE ERROR CODE C --------------------- C IERMS = 0 C C C --------------- C SET DEVICE TYPE C --------------- C DATA IDTN/71/ C C C ---------------- C CHECK PARAMETERS C ---------------- C IF(IOFSET.LT.0.OR.IOFSET.GT.1)GO TO 9100 C C C ---------------------------------- C SET HP 5355A OFFSET FREQUENCY MODE C ---------------------------------- C DO 50 ICNT = 1,21 IBUFR(ICNT) = 2H 50 CONTINUE C C OFFSET ON-OFF C ------------- C IBUFR = 2HOT IBUFR(2) = 30000B INX = 2 IF(IOFSET.EQ.0)GOTO 2000 C C SET FREQ OFFSET C --------------- C IBUFR(2) = 2H1O IBUFR(3) = 2HF INX = 4 C C SET OFFSET VALUE C ---------------- C VAL1 = OFMHZ IF(VAL1.LT.0.0)VAL1 = -OFMHZ IFLG = 0 C C FREQUENCY C --------- C VAL2 = OFHZ IF(VAL2.LT.0.0)VAL2 = -OFHZ IF(VAL1.GT.99999.)GOTO 9100 IF(VAL2.GT.999999.)GOTO 9100 ISIGN = 0 IF(OFMHZ.LT.0.0.OR.OFHZ.LT.0.0)ISIGN = 1 INX = 4 IF(ISIGN.EQ.0)IBUFR(INX) = 20000B IF(ISIGN.EQ.1)IBUFR(INX) = 26400B C C CONVERT 'OFMHZ' MHZ VALUE TO 5 ASCII DIGITS C ------------------------------------------- C IF(VAL1.EQ.0.0)GOTO 500 CALL GENFP(VAL1,NMBR) IF(NMBR.EQ.-1)GOTO 9100 C C FIND NUMBER OF DIGITS C --------------------- C NXM = 2 IF(NMBR.EQ.3.OR.NMBR.EQ.4)NXM = 3 IF(NMBR.LT.3)NXM = 4 IF(ISIGN.EQ.0)GOTO 480 C DO 475 I=NXM,4 IVAH = IAND(NMBR(I),177400B) / 256 IVLO = IAND(NMBR(I),377B) * 256 IBUFR(INX) = IOR(IBUFR(INX),IVAH) INX = INX + 1 475 IBUFR(INX) = IVLO C GOTO 500 C 480 CONTINUE DO 490 J = NXM, 4 IBUFR(INX) = NMBR(J) 490 INX = INX + 1 C IBUFR(INX) =27000B IF(VAL2.EQ.0.0)GOTO 2000 IFLG = 1 GOTO 510 C C C CONVERT 'OFHZ' HZ VALUE TO 6 ASCII DIGITS C ----------------------------------------- C 500 IF(VAL2.EQ.0.0)GOTO 2000 C C INSERT DECIMAL POINT C -------------------- C IBUFR(INX) = IOR(IBUFR(INX),56B) INX = INX + 1 IFLG = 0 510 CALL GENFP(VAL2,NMBR) IF(NMBR.EQ.-1)GOTO 9100 C C IF(IFLG.EQ.0)GOTO 560 C DO 550 J = 2 , 4 IVAH = IAND(NMBR(J),177400B) / 256 IVLO = IAND(NMBR(J),377B) * 256 IBUFR(INX) = IOR(IBUFR(INX),IVAH) INX = INX + 1 550 IBUFR(INX) = IVLO GOTO 2000 C 560 CONTINUE DO 570 J = 2, 4 IBUFR(INX) = NMBR(J) 570 INX = INX + 1 C INX = INX - 1 GOTO 2000 C 600 IF(VAL1.GT.99.9)GOTO 9100 ISIGN = 0 IF(OFMHZ.LT.0.0)ISIGN = 1 IF(ISIGN.EQ.0)IBUFR(INX) = 25400B IF(ISIGN.EQ.1)IBUFR(INX) = 26400B C C 620 INX = INX + 1 IBUFR(INX) = (NVAL+60B)*256 C C ------------- C REMOTE ENABLE C ------------- C 2000 CALL EXEC(100003B,1600B+LUIB) GOTO 8000 70 CALL ABREG(IA,IB) IF(IB .LT. 0) GOTO 990 C C SEND OUTPUT BUFFER C ------------------ C IVAL = IAND(IBUFR(INX),377B) IF(IVAL.EQ.0) IBUFR(INX) = IOR(IBUFR(INX),105B) IF(IVAL.EQ.0) IBUFR(INX+1) = 33000B INX = INX+1 IF(IVAL.NE.0)IBUFR(INX) = 42466B NUM = INX IF(IVAL.EQ.0)NUM = -(2 * INX - 1) C CALL REIO(100002B,LU1,IBUFR(1),NUM,IDUMY,0) GOTO 8000 71 CALL ABREG(IA,IB) IF(IB .LT. 0) GOTO 990 C C RETURN C ------ C C IERMS=0 RETURN C C ERROR EXIT C ---------- C 990 IERMS=IAND(IA,377B)+11 GOTO 9900 8000 IERMS=9 GOTO 9900 9100 IERMS = 1 9900 IERMS(2)=5 IERMS(3)=2HC4 IERMS(4)=2H5O IERMS(5)=2HF RETURN END C C C C ------------------------------------------------------ SUBROUTINE GENFP(FNUM,IFS),09580-16462 REV.2026 800130 C ------------------------------------------------------ C 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 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 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 ------------------- 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 ------------------------------------------ C IENUM CONTAINS INTEGER VALUE OF "E" (0-6). C NOW UNPACK CHARACTERS. C ------------------------------------------ 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 ------------------------ 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 --------------------------------- C 225 JFS(ID+1) = 60B C C DELETE DECIMAL POINT, ADJUST E VALUE C ------------------------------------ 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 ----------------------------- 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 ------------------ C DO 290 I=1,ISHFT JFS(I) = 60B 290 CONTINUE C C PACK CHARACTERS C --------------- 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 -------------------- C DO 320 I=5,6 IFS(I) = 20040B 320 CONTINUE C C C RETURN END END$