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$
                                                                                                              