FTN4,L
      SUBROUTINE TSYSM(IUNIT,IFUNC,STEP,MSTEP,IDNUP), 
     +09580-16454 REV.2001 790821 
C 
C-------------------------------------
C 
C  HP 5359A TIME SYNTHESIZER
C 
C  RELOCATABLE 09580-16454
C  SOURCE      09580-18454
C 
C  BOB RICHARDS   790821
C 
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     !
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 5953A
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 21-XX SERIES COMPUTER
C 
C  BRANCH AND MNEMONIC TABLE ENTRIES: 
C  ---------------------------------- 
C 
C    TSYSM(I,I,R,I,I)     OV=XX,   ENT=TSYSM,   FIL=%TSYSM
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    .
C    0
C 
C 
C 
C 
C-----------------------------------------------------------
C 
C------------------------------------ 
C 
C      TSYSM (IUNIT,IFUNC,STEP,MSTEP,IDNUP) 
C 
C     WHERE:
C 
C                   IUNIT = UNIT NUMBER 
C 
C                   IFUNC = 1 - FREQUENCY FUNCTION
C                         = 2 - PERIOD FUNCTION 
C                         = 3 - DELAY FUNCTION
C                         = 4 - WIDTH FUNCTION
C 
C                   STEP  = 6.25 TO 10E6 HZ (FREQUENCY) 
C                         = .0001E-3 TO 160E-3 SECONDS (PERIOD) 
C                         = 1(2) TO 999999 EVENTS FOR DELAY(WIDTH) IN EVENTS MODE 
C 
C                   MSTEP = 0 TO 16 MEG-EVENTS FOR DELAY/WIDTH. 
C 
C 
C                   IDNUP = STEP DIRECTION
C 
C                         = 0 FOR STEP DOWN 
C                         = 1 FOR STEP UP 
C 
C 
C 
C 
C 
C------------------------------------ 
      DIMENSION IERMS(5)
      DATA IDTN / 51 /
      DATA IERMS / 10,5,2HTS,2HYS,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 
      ISTN=ISN(DUMMY) 
      LU1=LUDV(ISTN,IDTN,IUNIT) 
      LUIB=IBLU0(LU1) 
      IF(LU1 .LE. 0 .OR. LUIB .LE. 0)GOTO 800 
C 
C  CALL X SUB 
C 
      CALL XSYSM(LU1,LUIB,IERMS,IUNIT,IFUNC,STEP,MSTEP,IDNUP) 
      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 XSYSM(LU1,LUIB,IERMS,IUNIT,IFUNC,STEP,MSTEP,IDNUP),
     +09580-16454 REV.2001 790821 
      DIMENSION IERMS(5),IBUF(42),IOBUF(9),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 
C  THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING
C  MEANINGS.
C 
C     LUIB = LU # OF HP-IB. 
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 
C  CHECK PARAMETERS 
C 
      IERMS=1 
      IF( DBUF .LT. 0.0 .AND. IFUNC .EQ. 1)GOTO8000 
      IF( DBUF .GT. 0.0 .AND. IFUNC .EQ. 2)GOTO8000 
      IF(IFUNC .EQ. 2 .AND. STEP .GT. 160E-3)GOTO8000 
      IF(IFUNC .EQ. 3 .AND.(EBUF .GE. 1.0 .AND. STEP .LT. 1.0))GOTO8000 
      IF(IFUNC .EQ. 3 .AND. (EBUF.LT. 1.0 .AND. STEP .GE. 1.0))GOTO8000 
      IF(IFUNC .EQ. 4 .AND. (WBUF.GE. 1.0 .AND. STEP .LT. 1.0))GOTO8000 
      IF(IFUNC .EQ. 4 .AND. (WBUF.LT. 1.0 .AND. STEP .GE. 1.0))GOTO8000 
      IF(IFUNC .LT. 1 .OR. IFUNC .GT. 4)GOTO8000
      IF(MSTEP .LT. 0 .OR. MSTEP .GT. 16)GOTO8000 
      IF(IDNUP .LT. 0 .OR. IDNUP .GT. 1)GOTO8000
      IF((IFUNC .EQ. 1 .OR. IFUNC .EQ. 2).AND. MSTEP .NE. 0)GOTO8000
C 
C  SET UP OUTPUT BUFFER 
C 
      IF (IFUNC .EQ. 1) IOBUF(1) = 2HF+ 
      IF (IFUNC .EQ. 2) IOBUF(1) = 2HP+ 
      IF (IFUNC .EQ. 3) IOBUF(1) = 2HD+ 
      IF (IFUNC .EQ. 4) IOBUF(1) = 2HW+ 
      IF ((IFUNC .EQ. 3 .OR. IFUNC .EQ. 4) .AND. STEP .LT. 1.0)GOTO200
      GO TO 300 
200   IOBUF(2) = 20040B 
      GO TO 320 
300   IF (MSTEP .GE. 10)GOTO310 
      IOBUF(2) = 30060B+MSTEP 
      GO TO 320 
310   IOBUF(2) = 30460B+MSTEP-12B 
320   DO 340 I = 1,6
      IFS(I) = 20040B 
340   CONTINUE
      IF (IFUNC .GE. 3) CALL TXF2A(STEP,IFS)
      IF (IFUNC .LE. 2) CALL F2A (STEP,IFS(1))
      DO 360 I = 2,6
      IOBUF(I+1) = IFS(I) 
360   CONTINUE
      IOBUF(8) = 2H , 
      IOBUF(9) = 2HSD 
      IF (IDNUP .EQ. 1) IOBUF(9) = 2HSU 
      INUM = 9
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)=2HYS 
      IERMS(5)=2HM
      RETURN
      END 
C 
      SUBROUTINE TXF2A(FNUM,IFS),09580-16454 REV.2001 790821
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$
                                                                                                                                                                                                        