FTN4,L
      SUBROUTINE TIMRS(IUNIT,IDAY,IHR,MIN,ISEC),
     +09580-16321 1926 790502 
C 
C-------------------------------------
C 
C  HP 59309A
C 
C  RELOCATABLE 09580-16321
C  SOURCE      09580-18321
C 
C  BOB RICHARDS  790109 
C  BOB RICHARDS  790502 
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 PROPRIETY    !
C  ! MATERIAL OF THE HEWLETT-PACKARD COMPANY.        !
C  !                                                 !
C  ! THIS SOURCE DATA SHALL BE USED SOLELY IN        !
C  ! CONJUCTION 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 59309A PROGRAMMABLE DIGITAL CLOCK. 
C 
C  HARDWARE REQUIRED: 
C  ------------------ 
C    A. HP 59309A 
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    TIMRS(I,I,I,I,I),        OV=XX,   ENT=TIMRS,   FIL=%TIMRS
C 
C  CONFIGURATION TABLE ENTRIES: 
C  ---------------------------- 
C 
C    R 59,1,1 
C    U1 
C       36N  WHERE N = 5 FOR COMMON YEAR
C                  N = 6 FOR LEAP YEAR
C 
C 
C 
C------------------------------------ 
C 
C  TIMRS(IUNIT,IDAY,IHR,MIN,ISEC) 
C 
C    WHERE: 
C 
C       IUNIT = UNIT #
C 
C       IDAY  = DAY OF YEAR, 1-365 (366 FOR LEAP YEAR)
C 
C       IHR   = HOUR OF DAY, 0-23 
C 
C       MIN   = MINUTE OF HOUR, 0-59
C 
C       ISEC  = SECOND OF MINUTE, 0-59
C 
C 
C 
C------------------------------------ 
      DIMENSION IERMS(5)
      DATA IDTN / 59 /
      DATA IERMS / 10,5,2HTI,2HMR,2HS  /
C 
      IERMS=10
C 
C  FIND STATION AND LU #'S
C   ISTN = STATION #
C   LU1 = HP 59309A LU
C   LUIB = HPIB 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 XIMRS(LU1,LUIB,IERMS,IUNIT,IDAY,IHR,MIN,ISEC)
      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 XIMRS(LU1,LUIB,IR,IU,IDA,IHR,MIN,ISE), 
     +09580-16321 1926 790502 
      DIMENSION IR(5),IOBUF(255),IBUF(1),IREG(2)
      EQUIVALENCE (IBUF(1),NODAY),(REG,IREG,IA),(IREG(2),IB)
C 
C---------------------------------------------
C 
C 
C  THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING
C  MEANINGS.
C 
C     LUIB = LU # OF HPIB BUS.  
C     LU1  = LU # OF HP-59309A
C 
C    IR IS A FIVE WORD ARRAY WITH IER CONTAINING
C      THE ERROR CODE.
C 
C        0 = NO ERROR 
C        1 = PARAMETER ERROR
C 
C    ERROR MESSAGES THAT PERTAIN TO THE HPIB. 
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    IR(2) = ERROR MNEMONIC CHARACTER COUNT 
C    IR(3) TO IR(5) = ERROR MNEMONIC
C 
C 
C---------------------------------------------
C 
C 
C  RETRIEVE CONFIGURATION DATA
C 
      CALL TIM(59,IU,1,IBUF,1,IER)
      IF(IER .NE. 0)RETURN
C 
C  CHECK PARAMETERS 
C 
      IR=1
      IF(IDA .LT. 1 .OR. IDA .GT. NODAY) GOTO 8000
      IF(IHR .LT. 0 .OR. IHR  .GT. 23) GOTO 8000
      IF(MIN  .LT. 0 .OR. MIN .GT. 59) GOTO 8000
      IF(ISE .LT. 0 .OR. ISE .GT. 59) GOTO 8000 
C 
C  SET UP OUTPUT BUFFER 
C 
      INUM = 2
      IODEV = 1 
      IOBUF(1) = 2HPR 
C 
C  SECOND UPDATE
C 
      IF (ISE .EQ. 0) GOTO 200
      DO 190 I=1,ISE
      IF (IODEV .EQ. 1) GOTO 175
      IOBUF(INUM) = IOBUF(INUM) + 123B
      IODEV = 1 
      INUM = INUM + 1 
      GOTO 190
175   IOBUF(INUM) = 51400B
      IODEV = 0 
190   CONTINUE
C 
C  MINUTE UPDATE
C 
200   IF (MIN .EQ. 0) GOTO 300
      DO 290 I=1,MIN
      IF (IODEV .EQ. 1) GOTO 275
      IOBUF(INUM) = IOBUF(INUM) + 115B
      IODEV = 1 
      INUM = INUM + 1 
      GOTO 290
275   IOBUF(INUM) = 46400B
      IODEV = 0 
290   CONTINUE
C 
C  HOUR UPDATE
C 
300   IF (IHR .EQ. 0) GOTO 400
      DO 390 I=1,IHR
      IF (IODEV .EQ. 1) GOTO 375
      IOBUF(INUM) = IOBUF(INUM) + 110B
      IODEV = 1 
      INUM = INUM + 1 
      GOTO 390
375   IOBUF(INUM) = 44000B
      IODEV = 0 
390   CONTINUE
C 
C  DAY UPDATE 
C 
400   IDA = IDA - 1 
      IF (IDA .EQ. 0) GOTO 500
      DO 490 I=1,IDA
      IF (IODEV .EQ. 1) GOTO 475
      IOBUF(INUM) = IOBUF(INUM) + 104B
      IODEV = 1 
      INUM = INUM + 1 
      GOTO 490
475   IOBUF(INUM) = 42000B
      IODEV = 0 
490   CONTINUE
C 
C 
C 
500   IF (IODEV .EQ. 1) GOTO 550
      IOBUF(INUM) = IOBUF(INUM) + 124B
      GOTO 2000 
550   IOBUF(INUM) = 2HT 
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 
      IR=0
      RETURN
C 
C  ERROR EXIT 
C 
8500  IR=IAND(IA,377B)+11 
      GOTO 8000 
9000  IR=9
8000  IR(2)=5 
      IR(3)=2HTI
      IR(4)=2HMR
      IR(5)=2HS 
      RETURN
      END 
      END$
                                              