FTN4,L
      SUBROUTINE TSYFM(IUNIT,DATA,DELAY,MDELY,WIDTH,MWDTH), 
     +09580-16453 REV.2026 800131 
C 
C-------------------------------------
C 
C  HP 5359A 
C 
C  RELOCATABLE 09580-16453
C  SOURCE      09580-18453
C 
C  BOB RICHARDS  790821 
C  BOB RICHARDS  791023 
C  BOB RICHARDS  800131  CHANGE REFERENCE FROM 'GETST' TO 'STGET'.
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 HP 5359A TIME SYNTHESIZER. 
C 
C  HARDWARE REQUIRED: 
C  ------------------ 
C    A. HP 5359A
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    TSYFM(I,R,R,I,R,I)   OV=XX,   ENT=TSYFM,   FIL=%TSYFM
C 
C  CONFIGURATION TABLE ENTRIES: 
C  ---------------------------- 
C 
C    R 51,1,42
C    U1 
C    *
C      0                 * 42 "0" ENTRIES 
C      0
C      0
C      .
C      .
C 
C      .
C      0
C      0
C 
C 
C 
C-------------------------------------------------------------------
C 
C  THE 5359A OFTEN OUTPUTS STATUS WORDS NEEDED BY THE ATS PRO-
C  GRAMMER FOR MORE COMPLETE PROGRAMMING CONTROL.  SEE THE 5359A
C  OPERATING AND PROGRAMMING MANUAL, ESPECIALLY TABLE 3-5, FOR MORE 
C  DETAILS ON STATUS WORD MEANINGS. 
C 
C  PROGRAMS 'DVSTS' AND 'DVINT' MUST BE LOADED PRIOR TO RUNNING 
C  'BASIC'.  THE FOLLOWING EXAMPLE ASSUMES THAT THE LOGICAL UNIT
C  ENTRY FOR THE 5359A HAS BEEN SET TO '12' IN 'DVINT'. 
C 
C       100 LET S = ISN(0)
C       110 LET L = LUDV(S,51,1)
C       120 TRAP 12 GOSUB 1000
C       130 CALL SRQ(L,16,"DVSTS")
C       140 CALL HPIB(L,14,0) 
C       . 
C       . 
C 
C 
C       . 
C       1000 REM TRAP SUBROUTINE
C       1010 STGET(L,T) 
C       1020 LET O = OCT(T) 
C       1030 PRINT "STATUS WORD = ",O 
C       1040 CALL SRQ(L,17,0) 
C       1050 RETURN 
C 
C 
C 
C------------------------------------ 
C 
C  TSYFM(IUNIT,DATA,DELAY,MDELY,WIDTH,MWDTH)
C 
C    WHERE: 
C 
C       IUNIT = UNIT #
C 
C       DATA  = 6.25 TO 10000000   HZ FOR FREQUENCY 
C             = .0000001 TO .160 SECONDS FOR PERIOD 
C             = 0.0 FOR EXTERNAL TRIGGER
C 
C       DELAY =  0.0 TO .160 SECONDS FOR EXTERNAL TRIGGER/DELAY 
C             =  2 TO 999999 EVENTS FOR EXTERNAL TRIGGER/DELAY
C 
C       MDELY = 0 TO 16 MEG EVENTS FOR EXTERNAL TRIGGER/DELAY 
C               (MDELY + DELAY <= 16777215) 
C 
C       WIDTH = .000000005 TO .160 SECONDS FOR EXT TRIG/DELAY 
C               (WIDTH + DELAY <= 160E-3) 
C             = 1 TO 999999 EVENTS FOR EXTERNAL TRIGGER/DELAY 
C                (WIDTH + DELAY <= 16777216)
C 
C       MWDTH = 0 TO 16 MEG EVENTS FOR EXTERNAL TRIGGER/DELAY 
C               (WIDTH + MWDTH <= 16777214) 
C 
C 
C 
C------------------------------------ 
      DIMENSION IERMS(5)
      DATA IDTN / 51 /
      DATA IERMS / 10,5,2HTS,2HYF,2HM  /
C 
      IERMS=10
C 
C  FIND STATION AND LU #'S
C   ISTN = STATION #
C   LU1 = HP-5359A LU 
C   LUIB = HP-IB LU 
C 
C 
      ISTN = ISN(DUMMY) 
      LU1 = LUDV(ISTN,IDTN,IUNIT) 
      LUIB = IBLU0(LU1) 
      IF(LU1 .LE. 0 .OR. LUIB .LE. 0) GO TO 800 
C 
C 
C  CALL X SUB 
C 
      CALL XSYFM(LU1,LUIB,IERMS,IUNIT,DATA,DELAY,MDELY,WIDTH,MWDTH) 
      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 XSYFM(LU1,LUIB,IERMS,IUNIT,DTA,DLY,MDLY,WIDTH,MWDTH),
     +09580-16453 REV.2026 800131 
      DIMENSION IERMS(5),IBUF(42),CBUF(1),IOBUF(24),IFS(6)
      DIMENSION DBUF(1),EBUF(1),WBUF(1) 
      EQUIVALENCE (DBUF,IBUF(2)),(EBUF,IBUF(4)),(WBUF,IBUF(7))
      IBUFL = 42
C---------------------------------------------
C 
C 
C  THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING
C  MEANINGS.
C 
C     LUIB = LU # OF HP-IB BUSS.
C     LU1  = LU # OF HP-5359A 
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 HP-IB.
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  RETRIEVE CONFIGURATION DATA
C 
      CALL TIM(51,IUNIT,1,IBUF,IBUFL,IER) 
      IF (IER .NE. 0) RETURN
C 
      IERMS=1 
      DO 240  I = 1,24
      IOBUF(I) = 20040B 
240   CONTINUE
C 
C 
      IF(DTA.NE.0.0.OR.DLY.NE.0.0.OR.WIDTH.NE.0.0) GO TO 250
      IF(MDLY .EQ. 0 .AND. MWDTH .EQ. 0) GO TO 700
C 
C     CHECK FOR EXTERNAL TRIGGER MODE 
C 
250   IF(DTA .EQ. 0.0) GO TO 280
C 
C     FREQUENCY/PERIOD OR TRIGGERED FREQUENCY 
C 
      IF(DLY .NE. 0.0 .OR. MDLY .NE. 0) GO TO 8000
      IF(DTA.GT.1.0.AND.(DTA.LT.6.25.OR.DTA.GT.10E6))GO TO 8000 
      IF(DTA.LT.1.0.AND.(DTA.LT.1E-7.OR.DTA.GT.16E-2))GO TO 8000
      IF(WIDTH .LT. 5E-9 .OR. WIDTH .GT. 16E-2) GO TO 8000
      IF(MWDTH .NE. 0 .OR. MDELY .NE. 0) GO TO 8000 
      IF(DTA .LT. 1.0 .AND. (DTA .LT. (WIDTH+85E-9))) GO TO 8000
      IF(DTA .GE. 1.0 .AND. (1.0/DTA) .LE. WIDTH) GO TO 8000
      GO TO 300 
C 
C     EXTERNAL TRIGGER (EVENTS OR DELAY)
C 
280   IF (DLY .GT. 16E-2 .OR. MDLY .GT. 0) GO TO 290
C 
C     DELAY 
C 
      IF(DLY .LT.0.0 .OR. DLY .GT.16E-2) GO TO 8000 
      IF(WIDTH .LT. 5E-9 .OR. WIDTH .GT. 16E-2) GO TO 8000
      IF((WIDTH + DLY) .GT. 16E-2) GO TO 8000 
      IF(MWDTH .NE. 0 .OR. MDLY .NE. 0) GO TO 8000
      GO TO 300 
C 
C     EVENTS
C 
290   IF(DLY .LT. 2.0 .AND. MDLY .EQ. 0) GO TO 8000 
      IF(DLY .GT. 777215.0 .AND. MDLY .EQ. 16) GO TO 8000 
      IF(WIDTH .LT. 1.0 .AND. MWDTH .EQ. 0) GO TO 8000
      IF(WIDTH .GT. 777214.0 .AND. MWDTH .EQ. 16) GO TO 8000
      IF(WIDTH .GT. 999999.0 ) GO TO 8000 
      IF(DLY .GT. 999999.0) GO TO 8000
      IF(MDLY .LT. 0 .OR. MDLY .GT. 16) GO TO 8000
      IF(MWDTH .LT. 0 .OR. MWDTH .GT. 16) GO TO 8000
      IF((MDLY+MWDTH).GE.16.AND.(WIDTH+DLY).GT.777216.0)GOTO8000
C 
C     SET UP OUTPUT BUFFER
C 
300   IF (DTA .EQ. 0.0) GO TO 370 
      IF (DTA .LT. 1.0) GO TO 305 
      IOBUF(1) = 2HF+ 
      GO TO 310 
305   IOBUF(1) = 2HP+ 
310   DO 320 I= 1,6 
      IFS(I) = 20040B 
320   CONTINUE
      CALL F2A(DTA,IFS(1))
      DO 350  I=2,6 
      IOBUF(I) = IFS(I) 
350   CONTINUE
      IOBUF(7) = 2H , 
370   IF (DLY .LT. 1.0) GO TO 500 
C 
C     DLY AND WIDTH IS IN EVENTS
C 
      DLY = AINT(DLY) 
      IF(DLY.EQ.0..AND.DTA.NE.0..AND.MDLY.EQ.0)GOTO455
      IOBUF(8) = 2HD+ 
      IF (MDLY .GE. 10) GO TO 400 
      IOBUF(9) = 30060B + MDLY
      GO TO 410 
400   IOBUF(9) = 30460B + MDLY - 12B
410   DO 420  I=1,6 
      IFS(I) = 20040B 
420   CONTINUE
      CALL TSF2A(DLY,IFS) 
      IF (IFS(1) .EQ. -1) GO TO 8000
      DO 450  I= 2,6
      IOBUF(I+8) = IFS(I) 
450   CONTINUE
      IOBUF(15) =2H , 
455   IOBUF(16) = 2HW+
      WIDTH = AINT(WIDTH) 
      IF(MWDTH .GE. 10) GO TO 460 
      IOBUF(17) = 30060B + MWDTH
      GO TO 470 
460   IOBUF(17) = 30460B + MWDTH - 12B
470   DO 480  I= 1,6
      IFS(I) = 20040B 
480   CONTINUE
      CALL TSF2A(WIDTH,IFS) 
      IF (IFS(1) .EQ. -1) GO TO 8000
      DO 490  I=2,6 
      IOBUF(I+16) = IFS(I)
490   CONTINUE
      IOBUF(23) = 2H ,
      GO TO 600 
C 
C     DLY AND WIDTH IS IN TIME
C 
500   IF (DLY .EQ. 0.0 .AND. DTA .NE. 0.0) GO TO 545
      IOBUF(8) = 2HD+ 
      DO 520  I=1,6 
      IFS(I) = 20040B 
520   CONTINUE
      CALL F2A(DLY,IFS(1))
      DO 530  I=2,6 
      IOBUF(I+8) = IFS(I) 
530   CONTINUE
      IOBUF(15) = 2H ,
      DO 540  I=1,6 
      IFS(I) = 20040B 
540   CONTINUE
545   IOBUF(16) = 2HW+
      CALL F2A(WIDTH,IFS(1))
      DO 550 I = 2,6
      IOBUF(I+16) = IFS(I)
550   CONTINUE
      IOBUF(23) = 2H ,
C 
C     ENABLE OUTPUT 
C 
C 
600   IOBUF(24) = 2HOE
      INUM = 24 
      GO TO 800 
C 
C 
C     DISABLE OUTPUT ON ZERO DATA ENTRY 
C 
700   IOBUF(1) = 2HOD 
      INUM = 1
C 
C 
C     STORE DATA IN SAM 
C 
800   DBUF = DTA
      EBUF = DLY
      IBUF(6) = MDLY
      WBUF = WIDTH
      IBUF(9) = MWDTH 
C$    CALL TIM(51,IUNIT,2,IBUF,IBUFL,IER) 
C$    IF (IER .NE. 0) RETURN
C 
C 
C 
C 
C  REMOTE ENABLE
C 
2000  CALL EXEC(100003B,1600B+LUIB) 
      GOTO 9000 
  70  CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
C 
C  SEND OUTPUT BUFFER 
C 
      CALL REIO(100002B,LU1,IOBUF(1),INUM,IDUMY,0)
      GOTO 9000 
  71  CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
C 
C 
C  RETURN 
C 
      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)=2HTS 
      IERMS(4)=2HYF 
      IERMS(5)=2HM
      RETURN
      END 
C 
C 
      SUBROUTINE TSF2A(FNUM,IFS),09580-16453 REV.2026 800131
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     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 
      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 
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     IENUM CONTAINS INTEGER VALUE OF "E" (0-6).
C     NOW UNPACK CHARACTERS.
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 
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 
225   JFS(ID+1) = 60B 
C 
C     DELETE DECIMAL POINT, ADJUST E VALUE
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 
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 
      DO 290 I=1,ISHFT
      JFS(I) = 60B
290   CONTINUE
C 
C     PACK CHARACTERS 
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 
      DO 320 I=5,6
      IFS(I) = 20040B 
320   CONTINUE
C 
C 
C 
      RETURN
      END 
      END$
                                                                                                              