FTN4,L SUBROUTINE RFOSO (IUN,RMHZ,RKHZ,RLEVL), +09580-16279 REV.2001 791023 C C*********************************************** C C RELOCATABLE 09580-16279 C SOURCE 09580-18279 C C ROSEMARY MCNALLY 8-31-77 C BOB RICHARDS 791023 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 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 COPY ! C ! MAY BE MADE AND RETAINED BY THE USER FOR ARCHIVE ! C ! 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 HP 8660A SYNTHESIZED SIGNAL GENERATOR C ------------------------------------- C C GENERAL C ------- C C THE FOLLOWING DEVICE SUBROUTINE IS USED C TO PROGRAM THE HP 8660A SYNTHESIZED SIGNAL C GENERATOR. C C HARDWARE REQUIRED C ----------------- C A. INSTRUMENT/OPTIONS: 8660A C B. I/O CARD: 59310-60101 C C. CABLE: 59310-60002 C C ADDRESS/JUMPER CONFIGURATION C ---------------------------- C I/O CARD JUMPER POSITIONS C C SW1 - ALL OFF (OPEN) C SW2 - 1=0,2=0,3=0,4=0,5=1 C 6=REN,7=ICF,8=CNX C W1 - OUT C C BRANCH AND MNEMONIC TABLE ENTRIES: C ---------------------------------- C C RFOSO(I,R,R,R), OV=XX, ENT=RFOSO, FIL=%RFOSO C DIMENSION IERMS(5) C C DEVICE TYPE #26 C DATA IDTN/26/ C C ERROR MNEMONIC C DATA IERMS/10,5,2HRF,2HOS,2HO / C C UNASSIGNED STATION OR LU# ERROR C IERMS=10 ISTN=ISN(DUMY) LUSG=LUDV(ISTN,IDTN,IUN) LUIB=IBLU0(LUSG) IF(LUSG.LE.0.OR.LUIB.LE.0)GOTO 1000 C C "X" ENTRY POINT C CALL XFOSO(LUIB,LUSG,IERMS,IUN,RMHZ,RKHZ,RLEVL) IF(IERMS.NE.0)GOTO 1000 RETURN C C ERROR EXIT C 1000 CALL ERROR(IERMS,IERMS(2)) RETURN END C********************************************************************* SUBROUTINE XFOSO(LUIB,LUSG,IERR,IUN,RMHZ,RKHZ,RLEVL), +09580-16279 REV.2001 791023 C********************************************************************** C C C RFOSO(IUN,RMHZ,RKHZ,RLEVL) C C WHERE: C C IUN= SELECTED UNIT NUMBER C RMHZ = MEGAHERTZ C 0 -- 2600 C RKHZ = KILLOHERTZ C -1000 TO +1000 C RLEVL = ATTENUATION IN DBM C -146 TO +13 C C*********************************************************************** C DIMENSION LBUF(10), IASC(3), IASC1(4), IASC2(3), IASC3(3), - IERR(5), IREG(2) EQUIVALENCE (REG,IREG,IA),(IREG(2),IB) DOUBLE PRECISION FREQ, F, N, L C C 1ST CHARACTER SENT IS FALSE ADDRESS "/" C DATA LBUF(1) / 2H / / C C C C ZERO BUFFERS C DO 11 I= 1,3 IASC1(I) = 0 IASC2(I) = 0 11 IASC3(I) = 0 IASC1(4) = 0 C C BLANK OUTPUT BUFFER C DO 1 I=1,10 1 LBUF(I)=2H C C CHECK FOR ERRORS C IERR=0 IF((RMHZ .LT. 0.0) .OR. (RMHZ .GT. 2600.0)) GOTO 100 IF(RKHZ .LT. -1000.0 .OR. RKHZ .GT. 1000.0) GOTO 100 IF(RLEVL .LT. -146.0 .OR. RLEVL .GT. 13.0)GOTO 100 IF((RMHZ .EQ. 0.0) .AND. (RKHZ .EQ. 0.0))GOTO 100 C C ADD RMHZ & RKHZ PARAMETERS C N=RKHZ*.001 FREQ=RMHZ+N C C SAVE THE SUM C C F=FREQ IF(FREQ.GE.1300.)FREQ=FREQ*.5 C C ISOLATE INTEGRAL # OF MEGAHERTZ C INMHZ=FREQ C C C ISOLATE INTEGRAL # OF KILOHERTZ C RNMHZ=INMHZ FREQ=(FREQ-RNMHZ+5.E-8)*1E3 INKHZ=FREQ C C ISOLATE INTEGRAL # OF HERTZ C RNKHZ=INKHZ FREQ=(FREQ-RNKHZ)*1E3 INHZ=FREQ C C FREQUENCY DOUBLING MODE??? C IF(1300.- F) 1300,1300,1299 C C "G" = X2-RANGE REGISTER ADDRESS C 1300 LBUF(7) = 2H(G GO TO 51 C C "I" = X1-RANGE REGISTER ADDRESS C 1299 LBUF(7) = 2H(I 51 CALL ASCII( IASC1, INMHZ ) C C FORMAT RMHZ WORDS LBUF(5), LBUF(6) C GO TO (91,92,93,94) IASC1(1) 91 LBUF(5) = IOR( IASC1(2), 60B ) LBUF(6) = 2H00 GO TO 410 92 LBUF(5) = IOR( LST(IASC1(2)), IRST(IASC1(2)) ) LBUF(6) = 2H00 GO TO 410 93 LBUF(5) = IOR( IASC1(3), IAND( IASC1(2), 377B ) ) LBUF(6) = IOR( IAND( IASC1(2), 177400B ), 60B ) GO TO 410 94 LBUF(5) = IOR( LST(IASC1(3)), IRST(IASC1(3)) ) LBUF(6) = IOR( LST(IASC1(2)), IRST(IASC1(2)) ) 410 CALL ASCII(IASC2,INKHZ) C C CONSTRUCT RKHZ WORDS LBUF(3),(4) C GO TO (101,102,103) IASC2(1) 101 LBUF(3) = IRST(IASC2(2)) LBUF(4) = 2H00 GOTO 110 102 LBUF(3) = IAND(IASC2(2),377B) LBUF(4)= IOR( IAND(IASC2(2),177400B), 60B ) GOTO 110 103 LBUF(3)=IRST(IASC2(3)) LBUF(4)=IOR( LST(IASC2(2)), IRST(IASC2(2)) ) 110 CALL ASCII(IASC3,INHZ) C C CONSTRUCT HZ WORDS LBUF(2),(3) C GO TO (201,202,203) IASC3(1) 201 LBUF(2)= IOR( IASC3(2), 60B ) IF( LBUF(3) .EQ. 0 ) LBUF(3) = 60B LBUF(3)=IOR(30000B,LBUF(3)) GOTO 801 202 LBUF(2)=IOR( LST(IASC3(2)), IRST(IASC3(2)) ) LBUF(3)=IOR(30000B,LBUF(3)) GOTO 801 203 LBUF(2) = IOR( IASC3(3), IAND( IASC3(2), 377B ) ) LBUF(3) = IOR( LBUF(3), IAND( IASC3(2), 177400B ) ) 801 CONTINUE C C C REMOTE ENABLE C CALL EXEC(100003B,1600B+LUIB) GOTO 900 35 CALL ABREG(IA,IB) IF(IB.LT.0)GOTO 990 C C C LAST CHARACTER SENT MUST BE ATTENUATION REGISTER ADDRESS ASCII "#" C LBUF(9)= 2H0# ISHFT = 2**8 LEVL=ABS(RLEVL-13.0) C C CONVERT INTEGER PARAMETER TO ASCII DIGITS C CALL ASCII(IASC,LEVL) C C NOTE CHARACTER COUNT & CONSTRUCT BUFFER ACCORDINGLY C GO TO (10,20,30) IASC(1) 10 LBUF(8) =(IAND( IASC(2),177400B))+60B GO TO 122 20 LBUF(8) = IAND( IASC(2), 377B )*ISHFT ITEMP=(IAND(IASC(2),177400B))/ISHFT LBUF(8) = LBUF(8)+ITEMP GO TO 122 30 LBUF(8) = IAND( IASC(3), 177400B ) LBUF(8) =(IAND( IASC(2),377B ))+LBUF(8) LBUF(9) =(IAND( IASC(2), 177400B ))+43B C C 1ST CHARACTER SENT USED TO BE FALSE ADDRESS ASCII "." C 122 CONTINUE CALL REIO(100002B,2000B+LUSG,LBUF(2),9,IDUMY,0) GOTO 900 43 CALL ABREG(IA,IB) IF(IB .LT. 0)GOTO 990 C C SUBROUTINE TO CHECK ABREG FOR DVR37 ERROR C C C RETURN C 100 IERR=1 GOTO 9000 900 IERR=9 GOTO 9000 990 IERR=IAND(IREG,377B)+11 9000 IERR(2)=5 IERR(3)=2HRF IERR(4)=2HOS IERR(5)=2HO RETURN END C FUNCTION LST( KVAL ),09580-16279 1840 ISHFT = 2**8 LST = IAND( KVAL, 377B ) * ISHFT RETURN END C FUNCTION IRST( NVAL ),09580-16279 1840 ISHFT = 2**8 IRST = IAND( 177400B, NVAL ) / ISHFT RETURN END END$