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$