FTN4,L
      SUBROUTINE GPRIO(IUNIT,IFUNC,RDATA),09580-16316 REV.2013 800131 
C 
C  THIS DEVICE SUBROUTINE IS USED TO PROGRAM THE 12566-60024
C  MICROCIRCUIT CARD. 
C 
C**************************************** 
C 
C  RELOCATABLE  09580-16316 
C  SOURCE       09580-18316 
C 
C  REY UNTALAN
C  BOB RICHARDS 790502
C  BOB RICHARDS 790517
C  BOB RICHARDS 791023
C  MILT NOGUCHI 791227
C  YOSH MIYAKO  800129
C  BOB RICHARDS 800131
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 MICRO-CIRCUIT CARD.
C --------------------- 
C 
C HARDWARE
C --------
C 
C 
C 
C   HP 12566-60024 MICROCIRCUIT CARD
C        JUMPERED AS FOLLOWS: 
C 
C         W1-A
C         W2-W4-B 
C         W5-W8-IN
C         W9-A
C 
C BRANCH AND MNEMONIC TABLE ENTRIES 
C 
C GPRIO(I,I,RV),   OV=XX,  ENT=GPRIO, FIL=%GPRIO
C GPRSB(I,I,I,IV), OV=XX,  ENT=GPRSB, FIL=%GPRIO
C 
C CONFIGURATION TABLE INFORMATION 
C 
C******************************** 
C* HP12566B MICROCIRCUIT REGISTER 
C******************************** 
C*
C  R 56,1,1 
C  U1 
C        0
C 
C 
C***************************************
C 
C 
C 
C   WHERE:
C          IUNIT= UNIT # OF I/O CARD
C 
C          IFUNC= FUNCTION
C                 0= INPUT OCTAL (READ DATA FROM CARD)
C                 1= OUTPUT OCTAL (WRITE DATA TO CARD)
C                 2= INPUT BCD (READ DATA FROM CARD)
C                 3= OUTPUT BCD (WRITE DATA TO CARD)
C 
C          RDATA= BIT PATTERN TO BE OUTPUT
C                 (0 TO 177777 OCTAL CODED) 
C                         OR
C                 BINARY (TO OCTAL) PATTERN RETURNED FROM CARD
C                         OR
C                 BIT PATTERN TO BE OUTPUT
C                 (0 TO 9999 BINARY CODED DECIMAL)
C                         OR
C                 BINARY (TO BCD) PATTERN RETURNED FROM CARD
C 
C 
C 
C   FUNCTION CODES FOR 16 BIT CONTROL: 0=OCTAL INPUT
C                      (GPRIO)         1=OCTAL OUTPUT 
C                                      2=BCD INPUT
C                                      3=BCD OUTPUT 
C 
C 
C 
C 
C 
C 
C     ERROR CODES:
C 
C       1 - PARAMETER ERROR 
C       2 - TIME OUT ERROR
C       3 - NON BCD CONVERTABLE BINARY READ ATTEMPT 
C       4 - NON BINARY
C       9 - I/O CALL REJECTED 
C      10 - UNIT #, LU # ERROR
C 
C 
C 
C 
C*****************************************
      DIMENSION IERMS(5)
      DATA IERMS/10,5,2HGP,2HRI,2HO / 
      DATA IDTN/56/ 
C 
C  FIND STATION # AND LU #
C 
      IERMS=10
      ISTN=ISN(DUMMY) 
      LU=LUDV(ISTN,IDTN,IUNIT)
      IF(LU)800,800,20
C 
20    CALL XPRIO(LU,IERMS,IUNIT,IFUNC,RDATA)
      IF(IERMS)800,30,800 
30    RETURN
C 
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
C 
C 
C 
C 
C=============================================
C 
      SUBROUTINE XPRIO(LU,IERR,IUNIT,IFUNC,RDATA),09580-16316 REV.2013 8
     +00131 
C 
C 
      DIMENSION IERR(5),ID(6),IREG(2),ITB(4),IG(4),IBCD(4)
      EQUIVALENCE(REG,IREG,IA),(IREG(2),IB) 
      DATA IDTN/56/ 
C 
C 
C CHECK FUNCTION PARAMETER
C 
      IF(IFUNC .LT. 0 .OR. IFUNC .GT. 3) GOTO 8000
C 
C 
C ZERO THE ERROR FLAG 
C 
C 
      IERR=0
C 
C 
C DETERMINE THE REQUESTED FUNCTION DESIRED
C 
C 
C IS IT AN OCTAL READ?
C 
C 
      IF(IFUNC .EQ. 0) GOTO 1000
C 
C 
C IS IT AN OCTAL WRITE? 
C 
C 
      IF(IFUNC .EQ. 1) GOTO 2010
C 
C 
C IS IT A BCD READ? 
C 
C 
      IF(IFUNC .EQ. 2) GOTO 3000
C 
C 
C IS IT A BCD WRITE?
C 
C 
      IF(IFUNC .EQ. 3) GOTO 4000
C 
C 
C OCTAL OUTPUT FUNCTION SELECTED
C 
C CHECK OUTPUT DATA WORD
C 
C 
C 
2010  IF(RDATA .LT. 0 .OR. RDATA .GT. 177777.) GOTO 8000
C 
C RESET BUFFER TO ZEROES
C 
      DO 50 I=1,6 
      ID(I)=0 
50    CONTINUE
C 
      RMSB=0
      IF(RDATA .GE. 100000.) RMSB=1.0 
      ID(1)=INT(RMSB) 
C 
      RD2=(RDATA-(RMSB*100000.))/10000. 
      ID(2)=INT(RD2)
C 
      KDATA=INT((RMSB*10.)+(RD2)) 
      PDATA=FLOAT(KDATA)*10000. 
      JDATA=RDATA-PDATA 
C 
C 
      ID(3)=JDATA/1000
C 
      ID(4)=(JDATA-(ID(3)*1000))/100
C 
      ID(5)=(JDATA-(ID(3)*1000)-(ID(4)*100))/10 
C 
      ID(6)=(JDATA-(ID(3)*1000)-(ID(4)*100)-(ID(5)*10)) 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C   CHECK EACH DIGIT
C 
      DO 100 I=1,6
      IF(ID(I) .GT. 7.) IERR=1
100   CONTINUE
C 
C 
C  POSITION EACH DIGIT TO FORM AN EQUIVALENT OCTAL WORD 
C 
      ID(1)=ID(1)*100000B 
      ID(2)=ID(2)*10000B
      ID(3)=ID(3)*1000B 
      ID(4)=ID(4)*100B
      ID(5)=ID(5)*10B 
C 
C 
C 
C 
C 
C 
C 
      IWRD=ID(1)
      DO 200 I=2,6
200   IWRD=IOR(ID(I),IWRD)
C 
C SAVE DATA WORD
C 
300   CALL TIM(IDTN,IUNIT,2,IWRD,1,JER) 
      IF(JER.NE.0) RETURN 
C 
C 
C 
C 
C  OUTPUT WORD TO I/O CARD
C 
      GOTO 2000 
C 
C 
C================================ 
C 
C READ DATA WORD FROM I/O CARD
C 
1000  CALL REIO(100001B,100B+LU,IDATA,1,IDUMY,0)
      GOTO 7000 
1100  CALL ABREG(IA,IB) 
      IF(IAND(IREG,377B) .NE. 0) GOTO 7500
C 
C 
C ISOLATE EACH OCTAL DIGIT
C 
C 
C 
C 
      ID(1)=IAND(100000B,IDATA)/100000B 
      ID(2)=IAND(70000B,IDATA)/10000B 
      ID(3)=IAND(7000B,IDATA)/1000B 
      ID(4)=IAND(700B,IDATA)/100B 
      ID(5)=IAND(70B,IDATA)/10B 
      ID(6)=IAND(7B,IDATA)
C 
C 
C CONVERT INTEGER TO REAL NUMBER. 
C 
C 
      RD1=ID(1) 
      RD2=ID(2) 
      RD3=ID(3) 
      RD4=ID(4) 
      RD5=ID(5) 
      RD6=ID(6) 
C 
C 
C MOVE TO THEIR RESPECTIVE PLACE HOLDINGS.
C 
C 
C 
C 
      RD1=RD1*100000. 
      RD2=RD2*10000.
      RD3=RD3*1000. 
      RD4=RD4*100.
      RD5=RD5*10. 
C 
C 
C BUILD THE WORD AND ADD THE LOW ORDER ENTRY TOO. 
C 
C 
      RWRD=RD1+RD2+RD3+RD4+RD5+RD6
C 
C 
C ASSIGN TO PASSING PARAMETER.
C 
C 
      RDATA=RWRD
C 
C 
C RETURN TO CALLING SEGMENT.
C 
C 
      RETURN
C 
C 
C OCTAL AND BCD OUTPUT ROUTINE ONCE WORD IS BUILT.
C 
C 
2000  CALL REIO(100002B,100B+LU,IWRD,1,IDUMY,0) 
C 
C 
C ERROR RETURN TRANSFER.
C 
C 
      GOTO 7000 
C 
C 
C RETURN POINT IF NO ERROR. 
C 
C 
2020  CALL ABREG(IA,IB) 
      IF(IAND(IREG,377B) .NE. 0) GOTO 7500
C 
C 
C RETURN TO MAIN CALLING SEGMENT. 
C 
C 
      RETURN
C 
C 
C BCD CONVERSION OF BINARY WORD INPUTTED. 
C 
C 
3000  CALL REIO(100001B,100B+LU,IDATA,1,IDUMY,0)
C 
C 
C ERROR RETURN TRANSFER STATEMENT.
C 
C 
      GO TO 7000
C 
C 
C NORMAL RETURN POINT.
C 
C 
C 
3100  CALL ABREG(IA,IB) 
C 
C 
C CHECK FOR TIME OUT ERROR. 
C 
C 
      IF(IAND(IREG,377B) .NE. 0) GO TO 7500 
C 
C 
C PARSE THE DATA WORD INPUTTED. 
C 
C 
      ITB(1)=IAND(10B,IDATA)/10B
      ITB(2)=IAND(200B,IDATA)/200B
      ITB(3)=IAND(4000B,IDATA)/4000B
      ITB(4)=IAND(100000B,IDATA)/100000B
      IG(1)=IAND(7B,IDATA)/1B 
      IG(2)=IAND(160B,IDATA)/20B
      IG(3)=IAND(3100B,IDATA)/400B
      IG(4)=IAND(70000B,IDATA)/10000B 
C 
C 
C CHECK TO SEE THAT ALL FOUR BCD DIGITS DO NOT EXCEED 9 
C 
C 
      DO 3050, I=1,4
C 
C 
C IF IT IS GREATER THAN 9, FLAG THE ERROR.
C 
C 
      IF((ITB(I) .EQ. 1) .AND. (IG(I) .GT. 1)) GO TO 7100 
3050  CONTINUE
C 
C 
C PARSE INTO BCD GROUPS.
C 
C 
      IBCDG1=IAND(17B,IDATA)/1B 
      IBCDG2=IAND(360B,IDATA)/20B 
      IBCDG3=IAND(7400B,IDATA)/400B 
      IBCDG4=IAND(170000B,IDATA)/10000B 
C 
C 
C CONVERT TO REAL.
C 
C 
      RBCD1=IBCDG1*1. 
      RBCD2=IBCDG2*10.
      RBCD3=IBCDG3*100. 
      IF(ITB(4) .EQ. 0) GO TO 3060
      IF(IG(4) .EQ. 0) RBCD4=8000.
      IF(IG(4) .EQ. 1) RBCD4=9000.
      GO TO 3090
 3060 RBCD4=IBCDG4*1000.
C 
C 
C FORM THE BCD WORD.
C 
C 
 3090 RDATA=RBCD1+RBCD2+RBCD3+RBCD4 
C 
C 
C RETURN TO THE CALLING PROGRAM.
C 
C 
      RETURN
C 
C 
C 
C BCD WRITE OPERATION.
C 
C 
C 
C RANGE CHECK BCD NUMBER. 
C 
C 
4000  IF(RDATA .LT. 0 .OR. RDATA .GT. 9999) GO TO 8000
C 
C 
C BEGIN CONVERSION TO BINARY FROM BCD.
C 
C 
C ZERO OUT THE BUILD ARRAY. 
C 
C 
      DO 4010, I=1,4
      IBCD(I)=0 
4010  CONTINUE
C 
C 
C PARSE RDATA OUT.
C 
C 
      IBCD(4)=INT(RDATA/1000.0) 
      IBCD(3)=INT((RDATA-IBCD(4)*1000.)/100.) 
      IBCD(2)=INT((RDATA-IBCD(4)*1000.-IBCD(3)*100.)/10.) 
      IBCD(1)=INT((RDATA-IBCD(4)*1000.-IBCD(3)*100.-IBCD(2)*10.)/1.)
C 
C 
C CHECK EACH DIGIT. 
C 
C 
      DO 4020, I=1,4
      IF(IBCD(I) .GT. 9) GO TO 4015 
      GO TO 4020
 4015 IERR=1
      GO TO 8500
 4020 CONTINUE
C 
C 
C POSITION EACH DIGIT TO FORM AN EQUIVALENT BCD WORD. 
C 
C 
      IBCD(1)=IBCD(1)*1B
      IBCD(2)=IBCD(2)*20B 
      IBCD(3)=IBCD(3)*400B
      IBCD(4)=IBCD(4)*10000B
C 
C 
C ADD UP TO FORM THE BINARY CONVERSION OF THE BCD WORD. 
C 
C 
      IWRD=IBCD(1)
      DO 4040, I=2,4
      IWRD=IOR(IBCD(I),IWRD)
4040  CONTINUE
C 
C 
C OUTPUT THE BCD CONVERTED TO BINARY WORD.
C 
C 
      GO TO 300 
C 
C 
C 
C 
C 
C ERROR EXIT
C 
C 
C 
C 
C 
C PARAMETER ERROR 
C 
C 
8000  IERR=1
      GOTO 8500 
C 
C 
C ATTEMPT TO READ A NON BCD CONVERTABLE BINARY NUMBER.
C 
C 
7100  IERR=3
      GO TO 8500
C 
C 
C THE I/O CALL HAS BEEN REJECTED. 
C 
C 
7000  IERR=9
      GOTO 8500 
C 
C 
C THERE HAS BEEN A TIME-OUT ERROR GENERATED.
C 
C 
7500  IERR=2
8500  IERR(2)=5 
      IERR(3)=2HGP
      IERR(4)=2HRI
      IERR(5)=2HOI
      RETURN
      END 
C***************************************
C 
      SUBROUTINE GPRSB(IUNIT,IFUNC,IPOS,ISTAT),09580-16316 REV.2013 8001
     +31
C 
C 
C   WHERE:
C          IUNIT= UNIT # OF I/O CARD
C 
C          IFUNC= FUNCTION
C                 0= INPUT STATE OF SPECIFIED BIT 
C 
C                 1= OUTPUT STATE OF SPECIFIED BIT WITH 
C                    ALL OTHER BITS UNCHANGED.
C 
C                 2= OUTPUT STATE OF SPECIFIED BIT WITH 
C                    ALL OTHER BITS SET TO ZERO.
C 
C                 3= OUTPUT STATE OF SPECIFIED BIT WITH 
C                    ALL OTHER BITS SET TO ONE. 
C 
C         IPOS  =  SPECIFIED BIT POSITION (0 TO 15) 
C 
C         ISTAT =  STATUS OF SPECIFIED BIT. 
C 
C*******************************************************************
C 
C     ALL THE EXAMPLES BELOW ASSUME THE CURRENT STATUS OF THE CARD
C     = 1110110111101011  (166753 OCTAL). 
C 
C 
C        EXAMPLE 1: 
C                   WITH IFUNC = 1 AND IPOS = 3, OUTPUT WILL BE:
C                   0000000000001000  (10 OCTAL)
C 
C        EXAMPLE 2: 
C                   WITH IFUNC = 1 AND IPOS = 2, OUTPUT WILL BE:
C                   0000000000000000  (0 OCTAL) 
C 
C        EXAMPLE 3: 
C                   WITH IFUNC = 2 AND IPOS = 9, OUTPUT WILL BE:
C                   1111110111111111  (176777 OCTAL)
C 
C        EXAMPLE 4: 
C                   WITH IFUNC = 2 AND IPOS = 8, OUTPUT WILL BE:
C                   1111111111111111  (177777 OCTAL)
C 
C 
C 
C 
C*****************************************
C 
      DIMENSION IERMS(5)
      DATA IERMS/10,5,2HGP,2HRS,2HB / 
      DATA IDTN/56/ 
C 
C  FIND STATION # AND LU #
C 
      IERMS=10
      ISTN=ISN(DUMMY) 
      LU=LUDV(ISTN,IDTN,IUNIT)
      IF(LU)800,800,20
C 
20    CALL XPRSB(LU,IERMS,IUNIT,IFUNC,IPOS,ISTAT) 
      IF(IERMS)800,30,800 
30    RETURN
C 
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
C 
C 
C 
C 
C=============================================
C 
      SUBROUTINE XPRSB(LU,IERR,IUNIT,IFUNC,IPOS,ISTAT),09580-16316 REV.2
     +013 800131
C 
C 
      DIMENSION IERR(5),ID(6),IREG(2) 
      EQUIVALENCE(REG,IREG,IA),(IREG(2),IB) 
      DATA IDTN/56/ 
C 
C 
C CHECK FUNCTION PARAMETER
C 
      IF(IFUNC .LT. 0 .OR. IFUNC .GT. 3) GOTO 8000
C 
C CHECK BIT POSITION SPECIFIER PARAMETER
C 
      IF(IPOS .LT. 0 .OR. IPOS .GT. 15) GOTO 8000 
C 
C 
      IERR=0
      IDATA=0B
      ICOMP=77777B
C 
C 
      IF(IPOS .EQ. 15) GO TO 20 
      IMASK=2**(IPOS) 
      GO TO 25
 20   IMASK=100000B 
 25   JMASK=IMASK 
      IF(IFUNC .NE. 0 .AND. ISTAT .EQ. 0) JMASK=0B
      NMASK=NOT(IMASK)
C 
C TEST FOR READ OPERATION 
C 
 30   IF(IFUNC .EQ. 0) GO TO 500
C 
C 
C 
C 
C NOT A READ, MUST BE A WRITE OPERATION.
C 
C 
C 
C 
C INPUT THE CURRENT BIT STATE IF SO SELECTED. 
C 
      IF(IFUNC .EQ. 1) GO TO 50 
C 
C NO.  PARSE IFUNC FURTHER. 
C 
      GO TO 200 
C 
C RETRIEVE DATA 
C 
50    CALL TIM(IDTN,IUNIT,1,JDATA,1,JER)
      IF(JER.NE.0) RETURN 
C 
C INCLUSIVE 'OR' THE TWO WORDS. 
C 
 100  JWORD=IOR(JDATA,JMASK)
      IF(ISTAT .EQ. 0) JWORD=IAND(JDATA,NMASK)
C 
C GO TO THE OUTPUT ROUTINE. 
C 
      GO TO 350 
C 
200   IF(IFUNC .EQ. 2) JWORD = JMASK
      IF(IFUNC .EQ. 2 .AND. ISTAT .EQ. 0) JWORD=0B
C 
C 
300   IF(IFUNC .EQ. 3) JWORD = IOR(JMASK,NMASK) 
C 
      IF(IFUNC .EQ. 3 .AND. IPOS .NE. 15) JWORD= IOR(JWORD,100000B) 
      IF(IFUNC .EQ. 3 .AND. ISTAT .EQ. 1) JWORD=177777B 
C 
C SAVE DATA WORD
C 
350   CALL TIM(IDTN,IUNIT,2,JWORD,1,JER)
      IF(JER.NE.0) RETURN 
C 
C 
C 
C   OUTPUT A WORD 
C 
C 
400   CALL REIO(100002B,100B+LU,JWORD,1,IDUMY,0)
      GOTO 7000 
420   CALL ABREG(IA,IB) 
      IF(IAND(IREG,377B) .NE. 0) GOTO 7500
C 
C 
      RETURN
C 
C 
C  READ BIT STATUS ONLY 
C 
C 
 500  CALL REIO(100001B,100B+LU,IDATA,1,IDUMY,0)
      GO TO 7000
 510  CALL ABREG(IA,IB) 
      IF(IAND(IREG,377B) .NE. 0) GOTO 7500
      ISTAT=0 
      IF(IAND(IDATA,IMASK) .NE. 0) ISTAT=1
C 
      RETURN
C 
C 
C 
C ERROR EXIT
C 
8000  IERR=1
      GOTO 8500 
7000  IERR=9
      GOTO 8500 
7500  IERR=2
8500  IERR(2)=5 
      IERR(3)=2HGP
      IERR(4)=2HRS
      IERR(5)=2HBI
      RETURN
      END 
      END$