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$