FTN4,L
C 
      PROGRAM MAPIO(3,85),24999-16222 REV.2024 800517 
C 
C  ******************************************** 
C  *                                          * 
C  *  RTE-IV SYSTEM I/O CONFIGURATION LISTOR  * 
C  *                                          * 
C  *  RELOC.: 24999-16222                     * 
C  *  SOURCE: 24999-18222                     * 
C  ******************************************** 
C 
C 
C  RUNNING INSTRUCTIONS REQUIREMENTS
C  ---------------------------------
C 
C     RU,MAPIO[,LIST],[START LU#],[END LU#],[FILTER1],[FILTER2] 
C 
C        LIST = LIST OUTPUT DEVICE LU, DEFAULT=LU 1 
C 
C        START LU# = START REPORTING THIS LU #, DEFAULT=1 
C                    (NOTE: IF THIS LU IS SPECIFIED AND 'END LU#' 
C                           IS NOT SPECIFIED. ONLY 'START LU#'
C                           WILL BE GIVEN.) 
C                     ALSO: IF START LU# = 'SC' A LIST BY SELECT
C                           CODE WILL BE GIVEN. 
C 
C        END LU#   = STOP REPORTING AFTER THIS LU #, DEFAULT=ALL LU'S 
C 
C        FILTER1   = DRIVER TYPE FILTER.  THIS PARAMTER ALLOWS YOU TO 
C                    FILTER ON A DRIVER TYPE.  EITHER AN OCTAL VALUE
C                    CAN BE GIVEN (E.G. 23B) OR AN ALPHANUMERIC STRING
C                    IN THE FOLLOWING FORM: 'A05'.  THIS WOULD ONLY 
C                    DISPLAY 'DVA05' TYPE LU'S. 
C                    (DEFAULT: FILTER1 = SHOW ALL LU'S) 
C 
C        FILTER2   = DRIVER TYPE FILTER.  THIS PARAMETER HAS THE SAME 
C                    FORMAT AS 'FILTER1' AND IS USED IN CONJUNTION
C                    WITH 'FILTER1' TO SPECIFY A RANGE OF DRIVER
C                    TYPES TO BE LISTED.
C                    (DEFAULT: FILTER2 = FILTER1) 
C 
C  EXTERNAL SUBROUTINES REQUIRED
C  -----------------------------
C 
C   IODVC          ASCII TABLE OF DRIVER DEVICE NAMES.
C   MEMSZ          CALCULATES RTE-IV MEMORY SIZE
C   ISOL8          ISOLATES AND RIGHT JUSTIFIES BITS
C 
      EXTERNAL IODVC,MEMSZ,ISOL8
C 
      INTEGER TYPE,TYPMIN,TYPMAX,TYPASC,ASCLL,ASCUL,WORD4 
C 
      LOGICAL DVFLT,SCLST 
C 
      DIMENSION IDVC(8),IPARM(5),MTH(36),NAME(3),LIBARY(256)
      DIMENSION IPBUF(10) 
      EQUIVALENCE(NAME(2),NAME2),(IPARM(5),IPARM5)
      EQUIVALENCE(IPBUF(4),WORD4) 
C 
      DATA MTH/2HJA,2HN ,2HFE,2HB ,2HMA,2HR ,2HAP,2HR ,2HMA,2HY ,2HJU,
     -2HN ,2HJU,2HL ,2HAU,2HG ,2HSE,2HP ,2HOC,2HT ,2HNO,2HV ,2HDE,2HC / 
      DATA LIBSIZ/256/,DVFLT/.FALSE./,ASCLL/26400B/,ASCUL/55000B/ 
      DATA SCLST/.FALSE./ 
C 
C  GET PARAMETERS AND SET DEFAULTS. 
C 
      CALL GETST(LIBARY,-40,ILOG) 
      LUOUT = LOGLU(LUTRUE) 
      IEQTB=IGET(1650B) 
      LUMAX = IGET(1653B) 
      INTBA = IGET(1654B) 
      INTLG = IGET(1655B) 
C 
C  START INTERRUPT TABLE AT 10B 
C 
      INTBA = INTBA + 2 
      ICODE = 10B 
C 
C MAKE SURE THE SC LIST DOES'NT START OFF WITH A BANG 
C 
      IEQTA = 77777B
C 
C  SET A STOP FLAG (FOR SC LIST)
C 
      ISTOP = 6 + INTLG 
      IBEG = 1
      IEND = LUMAX
      ISTRC = 1 
      DO 100 I=1,5
      IF(NAMR(IPBUF,LIBARY,ILOG,ISTRC))100,10 
10    TYPE = IAND(WORD4,3)
      GO TO(20,30,40,50,80)I
20    IF(TYPE .EQ. 1)LUOUT = IPBUF
      GO TO 100 
30    IF(TYPE .EQ. 3 .AND. IPBUF .EQ. 2HSC)GO TO 110
      IF(TYPE .NE. 1)GO TO 100
      IBEG = IPBUF
      IEND = IPBUF
      GO TO 100 
40    IF(TYPE .EQ. 0)GO TO 100
      IF(IPBUF .GT. IBEG)IEND = IPBUF 
      IF(IEND .GT. LUMAX)IEND = LUMAX 
      GO TO 100 
50    IF(TYPE .EQ. 0)GO TO 100
      DVFLT = .TRUE.
      IF(TYPE .NE. 1)GO TO 60 
      TYPMIN = IPBUF
      TYPMAX = IPBUF
      GO TO 100 
60    CALL CODE 
      READ(IPBUF,70)TYPMIN
70    FORMAT(O6)
      ASCLL = IAND(77400B,IPBUF)
      TYPMAX = TYPMIN 
      GO TO 100 
80    IF(TYPE .EQ. 0)GO TO 100
      IF(TYPE .NE. 1)GO TO 90 
      TYPMAX = IPBUF
      GO TO 100 
90    CALL CODE 
      READ(IPBUF,70)TYPMAX
      ASCUL = IAND(77400B,IPBUF)
100   CONTINUE
C 
C  IF ONLY ONE LU SPECIFIED SKIP THE HEADING AND FOOTING
C 
      IF(IBEG .EQ. IEND)GO TO 170 
      GO TO 120 
C 
C  IF S.C. LIST SET OUR FLAG
C 
110   SCLST = .TRUE.
C 
C     SET LINE SPACING CONTROL TO OUTPUT DEVICE 
C 
120   LUPC = IOR(LUOUT,1100B) 
C 
C     GET TBG AND PRIV. CARD INFO 
C 
      ITBG=IGET(1674B)
      IPRIV=IGET(1737B) 
C 
C     GET TIME AND DATE 
C 
      CALL EXEC(11,IPARM,IYEAR) 
      CALL DATE(IPARM5,MONTH,IYEAR) 
      IPM=(MONTH-1)*2+1 
      CALL MEMSZ(ISIZE) 
      WRITE(LUOUT,130)(MTH(I), I=IPM,IPM+1),IPARM5,IYEAR, 
     -(IPARM(I),I=4,2,-1) 
130   FORMAT(25X"RTE-IV SYSTEM CONFIGURATION"/25X,"ON ",2A2,I2, 
     -","I4"  AT"I3,2(":"I2)) 
      WRITE(LUOUT,140)ISIZE,ITBG
140   FORMAT(/20X"CONFIGURED MEMORY SIZE IS "I4" K WORDS",/,
     -22X"TIME BASE GENERATOR IS IN S.C. "K2) 
      IF(IPRIV.EQ.0)170,150 
150   WRITE(LUOUT,160)IPRIV 
160   FORMAT(/22X"PRIVILEGED INTERRUPT IS IN S.C. "K2)
170   WRITE(LUOUT,180)
180   FORMAT(/27X"----  E Q T  ----"/ 
     -3X"LU   EQT  S.CHNL  S.C.   ADDR STATUS  T.O.  DRIVER"
     -4X"DEVICE NAME"6X"LU"/) 
C 
C READ THE DISC LIBRARY OF ENTRY POINTS NEEDED FOR DRIVER NAMES.
C 
      CALL DISC(LIBARY,LIBSIZ,LUOUT,NENTI)
C 
C  IF SC LIST GO GET FIRST NON-ZERO SELECT CODE 
C 
      IF(SCLST)GO TO 290
C 
C  START IT ALL OVER AGAIN
C 
190   IDRT=IGET(1652B)
      IDRT = IDRT + IBEG - 1
C 
C START LOOP FOR ALL LUMAX LOGICAL UNITS. 
C 
      DO 360  I=IBEG,IEND 
       IDVR = 0 
       IF(IFBRK(IDUM))420,200 
200    IVAL=IGET(IDRT)
       IF(IVAL.NE.0) GO TO 220
       IF(DVFLT .OR. SCLST) GO TO 350 
       WRITE(LUOUT,210)I,I
210    FORMAT(I5,4X,18("*")"   LU UNASSIGNED  "18("*")9X,I4)
       GO TO 350
C 
C                    GET SUBCHANNEL 
C 
220    ISC=ISOL8(IVAL,15,11)
C 
C                    GET EQT NUMBER 
C 
       IEQT=IAND(IVAL,77B)
C 
C                    COMPUTE EQT ADDRESS
C 
       IEQTA=(IEQT-1)*15+IEQTB
C 
C                    EXTRACT SELECT CODE
C 
       ISCDE=IAND(IGET(IEQTA+3),77B)
C 
C    CHECK FOR LIST BY SELECT CODE ONLY 
C 
      IF(.NOT.SCLST) GO TO 230
      IF(ISCDE .NE. ICODE)GO TO 350 
C 
C                    AND DRIVER TYPE
C 
230    IDVR=ISOL8(IGET(IEQTA+4),13,8) 
C 
C                    SET DRIVER INITIATION ADDRESS
C 
       IENTRY=IGET(IEQTA+1) 
C 
C       AND SET TYPE IN NAME FOR SEARCH ROUTINE 
C 
       NAME = IDVR
C 
C                    SEARCH FOR TRUE DRIVER NAME
C 
       CALL SERCH(LIBARY,LIBSIZ ,NENTI,IENTRY,NAME) 
C 
C      DECODE EQT STATUS BITS 
C 
       ISTAT=IGET(IEQTA+3)
       IDB=20040B 
       IF(ISTAT.LT.0) IDB=42040B
       IF(IAND(ISTAT,40000B).NE.0) IDB=IOR(IAND(IDB,177400B),102B)
       IPS=20040B 
       IF(IAND(ISTAT,20000B).NE.0) IPS=50040B 
       IF(IAND(ISTAT,10000B).NE.0) IPS=IOR(IAND(IPS,177400B),123B)
       IT=20040B
       IF(IAND(ISTAT,4000B).NE.0) IT=52040B 
C 
C  DETERMINE DEVICE TIME OUT
C 
       ITO = 0
       MTO = IGET(IEQTA+13) 
       IF(MTO .EQ. 0)GO TO 240
       ITO = - (MTO+1)
C 
C  GET DEVICE NAME
C 
240    CALL IODVC(IDVR,IDVC,NAME,ISC) 
       TYPASC = IAND(NAME2,77400B)
C 
C  CHECK IF FILTERING OUTPUT
C 
      IF(.NOT.DVFLT)GO TO 260 
      IF(TYPMIN .LE. IDVR .AND. IDVR .LE. TYPMAX)GO TO 250
      GO TO 350 
C 
250   IF(ASCLL .LE. TYPASC .AND. TYPASC .LE. ASCUL)GO TO 260
      GO TO 350 
C 
C     OUTPUT 1 LU NUMBER
C 
260   WRITE(LUOUT,270)I,IEQT,ISC,ISCDE,IEQTA,IDB,IPS,IT,ITO,NAME,IDVC,I 
270   FORMAT(I5,I6,1X,I5,4X,K2,4X,K5,2X,3A2,I5,3X,3A2,2X,8A2,I4)  
      IF(.NOT.SCLST)GO TO 350 
280   ICODE = ICODE + 1 
      INTBA = INTBA + 1 
      IF(ICODE .EQ. ISTOP) GO TO 400
290   ICHK = IGET(INTBA)
C 
C  IF NEXT S.C. POINTS TO CURRENT EQT GO PRINT IT 
C 
      IF(ICHK .NE. IEQTA)GO TO 300
      ISCDE = ICODE 
      GO TO 260 
300   IF(ITBG .NE. ICODE)GO TO 320
      WRITE(LUOUT,310 )ICODE
      GO TO 280 
310   FORMAT(21X,K2,33X"TBG") 
320   IF(IPRIV .NE. ICODE)GO TO 340 
      WRITE(LUOUT,330 )ICODE
      GO TO 280 
330   FORMAT(21X,K2,33X"PRIVILEGED FENCE")
340   IF(ICHK .EQ. 0)GO TO 280
      GO TO 190 
350   IDRT=IDRT+1 
360   CONTINUE
C 
      IF(.NOT.SCLST)GO TO 390 
C 
C  NO LU FOUND BUT HAVE SOMETHING IN INTBL.  IF EQT ADDRESS WE
C  CAN PROCESS IT, IF PROGRAM TO SCHEDULE WE'RE OUT OF LUCK.
C 
      IF(ICHK .LT. 0)GO TO 370
C 
C SET UP A PASS THROUGH OUR LOOP
C 
      I = 999 
      ISC = 0 
      IEQT = (ICHK-IEQTB)/15 + 1
      IEQTA = ICHK
      ISCDE = ICODE 
      GO TO 230 
370   WRITE(LUOUT,380)ICODE 
380   FORMAT("  NO EQT DEFINED FOR "K2) 
      GO TO 280 
C 
C  SKIP THE FOOTING IF ONLY 1 LU. 
C 
390   IF(IBEG .EQ. IEND)GO TO 420 
C 
400   WRITE(LUOUT,410)
410   FORMAT(//36X"EQT STATUS LEGEND:"//37X"D= DMA REQUIRED"/37X
     -"B= AUTOMATIC OUTPUT BUFFERING USED"/37X"P= DRIVER PROCESSES" 
     -" POWER FAIL"/37X"S= DRIVER PROCESSES TIME-OUT"/37X"T= DEVICE"
     -" HAS TIMED OUT") 
420   CALL EXEC(3,LUPC,-1)
430   END 
      SUBROUTINE DATE(IDAY,MONTH,IYEAR) 
C 
C  THIS SUBROUTINE RECEIVES THE GREGORIAN (SOMETIMES MISTAKINGLY CALLED 
C  THE JULIAN) DATE IN 'IDAY' AND THE YEAR IN 'IYEAR' AND RETURNS THE 
C  FOLLOWING: 
C 
C       MONTH ---> NUMERICAL MONTH OF THE YEAR
C 
      DIMENSION IM(12)
      DATA IM/31,28,31,30,31,30,31,31,30,31,30,31/
C 
C 
C... CHECK FOR LEAP YEAR ...
C 
      IZ=IYEAR/4
      IR=IYEAR-IZ*4 
      IF(IR.NE.0) GO TO 70
C 
C... LEAP YEAR TIME ... 
C 
      IM(2)=29
C 
C... COMPUTE CORRECT MONTH ...
C 
   70 DO 20 I=1,12
      MONTH=I 
      IF(IDAY.LE.IM(I)) GO TO 30
   20 IDAY=IDAY-IM(I) 
C 
   30 END 
C 
      SUBROUTINE DISC(LIBARY,NLIB,LUOUT,NENTI)
C 
C    I MUST READ IN THE 
C DISC LIST OF USER AVAILABLE ENTRY POINTS STARTING AT DISC ADDRESS 
C GIVEN IN LOCATION DSCLB=1761B OF BASE PAGE COMMUNICATION AREA.
C    I WILL SORT OUT AND RETAIN IN LIBARY ARRAY ANY ENTRY POINTS THAT 
C MIGHT BE USEFUL(I AM LOOKING FOR I.00,IP43,ETC.). 
C 
      DIMENSION LIBARY(NLIB)
      INTEGER IREGS(2),AREG,BREG
      INTEGER SECTOR(128) 
      EQUIVALENCE(IREGS(1),REGS),(IREGS(1),AREG),(IREGS(2),BREG)
C 
C STATEMENT FUNCTION EXTRACTS 1ST CHAR OF ENTRY PT NAME.
C 
      INAME(IWD1)=IOR( ISOL8(IWD1,14,8), 20000B ) 
C 
C 
      IDISC=IGET(1761B) 
      LU=ISOL8(IDISC,15,15) + 2 
      ITK=ISOL8(IDISC,14,7) 
      ISEC=ISOL8(IDISC,6,0) 
      IODD = IAND(ISEC,1) 
      NENTRY=IGET(1762B)
      NSEC=IGET(1757B + LU - 2) 
      JENTRY=0
      ILIB=1
      IBUFL = 128 
      IF(IODD .EQ. 1)IBUFL = 64 
C 
C START LOOP TO READ DISC SECTOR BY SECTOR. 
C 
   10 CONTINUE
      REGS=EXEC(1,LU,SECTOR,IBUFL,ITK,ISEC) 
C 
C SECTOR HAS 32(OR 16) FIELDS OF 4 WDS EACH (3 FOR ENT PT NAME, 1 FOR ADDR) 
C SEARCH THIS SECTOR FOR ENTRY POINTS WITH PROMISING NAMES,BUT
C BREAK OUT IF WE EXCEED NENTRY ENTRY POINTS. 
C 
      DO 200 J=1,IBUFL/4
      JENTRY=JENTRY+1 
      IF(JENTRY.GT.NENTRY)GO TO 400 
      K=(J-1)*4 + 1 
      IF( INAME(SECTOR(K) ) .NE. 2H I ) GO TO 200 
C WE KNOW NAME BEGINS WITH I. NOW CHECK 6TH BYTE OF NAME. THIS BYTE 
C =0 FOR MEM RESIDENT, 1 FOR DISC RES, 4 FOR MICROCODE. WE WANT ONLY
C MEM RESIDENT ENT PTS BEGINNING WITH I.
      IF( ISOL8( SECTOR(K+2),7,0 ) .GT. 0 ) GO TO 200 
C 
C I FOUND A PROMISING NAME. I WILL STORE THE 3 WORD NAME AND ITS
C 1 WORD ADDRESS IN THE LIBARY ARRAY. 
C 
      DO 150 I=K,K+3
      LIBARY(ILIB)=SECTOR(I)
      ILIB=ILIB+1 
      IF(ILIB.GT.NLIB)GO TO 500 
  150 CONTINUE
  200 CONTINUE
C 
C ADDRESS THE NEXT SECTOR ON DISC.
C 
      ISEC=ISEC+1 
      IF(IODD .EQ. 0)ISEC = ISEC + 1
      IF(ISEC.LT.NSEC)GO TO 10
      ISEC=0
      IODD = 0
      IBUFL = 128 
      ITK=ITK+1 
      GO TO 10
C 
C DISC READ IS DONE. LIBARY ARRAY HAS ALL RELEVANT ENT PT NAMES.
C RETURN TO CALLER   NENTI=NUMBER OF ENTRY PT NAMES.
C 
  400 NENTI=(ILIB-1)/4
      RETURN
C 
C ERROR PRINTOUT IF TOO MANY ENT PT NAMES FOR THE LIBARY ARRAY. 
C 
  500 WRITE(LUOUT,510)ILIB
  510 FORMAT(I6," WDS OVERFLOWS LIBARY ARRAY")
      GO TO 400 
      END 
C 
      SUBROUTINE SERCH(LIBARY,NLIB,NENTI,IENTRY,NAMDV)
C 
C GIVEN THAT 2ND WORD OF EQT TABLE=ADDRESS OF INTERRUPT ENTRY POINT,
C FIND THE FIVE CHARACTER NAME OF THAT ENTRY POINT BY SEARCHING THE 
C LIBARY ARRAY OF USER AVAILABLE ENTRY POINTS.
C 
C LIBARY HAS NENTI FIELDS OF 4 WDS EACH (3 FOR ENT PT NAME, 1 FOR ADDR) 
C SEARCH THIS ARRAY FOR ENTRY POINT ADDR TO MATCH IENTRY. 
C 
      DIMENSION LIBARY(NLIB),NAMDV(3) 
      CALL CNUMO(NAMDV,NAMDV) 
      IDVR = NAMDV(3) 
      IF(IDVR .LT. 30000B)IDVR = IDVR + 10000B
      IDOT = ISOL8(2H..,7,0)
      IRIGHT = ISOL8(IDVR,14,8) 
      NAMDV(1) = 2HDV 
      NAMDV(2) = IOR((IDOT*256),IRIGHT) 
      NAMDV(3) = IOR(ISOL8(IDVR,6,0)*256,40B) 
      DO 200 J=1,NENTI
      K=(J-1)*4 + 4 
      IDV = K-2 
      IF(IDVR .NE. LIBARY(IDV))GO TO 200
      IF(LIBARY(K).NE.IENTRY)GO TO 200
C 
C I FOUND AN ADDRESS THAT MATCHES IENTRY. GET ENTRY PT NAME AND 
C CHANGE I.05 TO DVR05  OR  IX05 TO DVX05  FOR ANY X. 
C 
      NAMDV(3)=IOR( ISOL8( LIBARY(IDV), 6, 0)*256, 40B )
      IRIGHT=ISOL8( LIBARY(IDV),14,8 )
      ITEST=ISOL8( LIBARY(K-3), 6, 0 )
      IF(ITEST.EQ.IDOT)ILEFT=IAND( 2HRR, 177400B )
      IF(ITEST.NE.IDOT)ILEFT=ITEST*256
      NAMDV(2)=IOR(ILEFT,IRIGHT)
      RETURN
  200 CONTINUE
C 
C MISSED COMPLETELY. NO MATCH BETWEEN DRIVER TYPE AND ENTRY 
C POINT INDICATES THE DRIVER TYPE HAS BEEN CHANGED IN THE EQT 
C (THIS IS DONE BY THE SPOOL DRIVER FOR EXAMPLE). 
C IF THIS CONDITION OCCURS A DV.XX NAME WILL BE RETURNED IN THE 
C NAME ARRAY. 
C 
      RETURN
      END 
      END$
ASMB,L
* 
 HED MAPIO SUBROUTINE TO GET ASCII NAME OF DRIVER TYPE
      NAM IODVC,7 24999-16222 REV.2011 800312 
* 
      ENT IODVC 
      EXT .ENTR 
* 
*************************** 
*                         * 
*   SOURCE: 24999-18222   * 
*   RELOC.: 24999-16222   * 
*                         * 
*************************** 
* 
A     EQU 0 
B     EQU 1 
* 
      SUP 
* 
TABLE EQU * **  ASCII  **     ##
* 
      ASC 8,DUMB TERMINAL    R00
      ASC 8,TAPE READER      R01
      ASC 8,TAPE PUNCH       R02
      ASC 8,                 R03
      ASC 8,                 R04
      ASC 8,2645/2648 TRMNL  R05
      ASC 8,                 R06
      ASC 8,MULTI-PT TRMNL   R07
      ASC 8,PLOTTER          R10
      ASC 8,CARD READER      R11
      ASC 8,2767 LP          R12
      ASC 8,TV MONITOR       A13
      ASC 8,                 R14
      ASC 8,MARK READER      R15
      ASC 8,                 R16
      ASC 8,                 R17
      ASC 8,                 R20
      ASC 8,                 R21
      ASC 8,                 R22
      ASC 8,9-TR MAG TAPE    R23
      ASC 8,7-TR MAG TAPE    R24
      ASC 8,                 R25
      ASC 8,                 R26
      ASC 8,                 R27
      ASC 8,FIXED HEAD DISC  R30
      ASC 8,7900 DISC        R31
      ASC 8,7905/6/20/25 DSC R32
      ASC 8,FLEXIBLE DISC    R33
      ASC 8,                 R34
      ASC 8,                 R35
      ASC 8,WCS              R36
      ASC 8,HP-IB BUS        R37
      ASC 8,DATA SOURCE INT. R40
      ASC 8,                 R41
      ASC 8,                 R42
      ASC 8,SPOOL            R43
      ASC 8,                 R44
      ASC 8,3480/5 DVM       R45
      ASC 8,3480/4 DVM       R46
      ASC 8,3480/4/2911 DVM  R47
      ASC 8,RJE              R50
      ASC 8,                 R51
      ASC 8,                 R52
      ASC 8,                 R53
      ASC 8,40-BIT OUTPUT RG R54
      ASC 8,2312 SUBSY       R55
      ASC 8,2310/11 SS       R56
      ASC 8,                 R57
      ASC 8,                 R60
      ASC 8,6940 SUBSY       R61
      ASC 8,2313 SUBSY       R62
      ASC 8,                 R63
      ASC 8,                 R64
      ASC 8,DS/1000 LINK     A65
      ASC 8,2570A COM        R66
      ASC 8,DS/3000 LINK     G67
      ASC 8,6129/30/31 DVS   R70
      ASC 8,                 R71
      ASC 8,6940 SUBSY       A72
      ASC 8,                 R73
      ASC 8,2321 SUBSY       R74
      ASC 8,                 R75
      ASC 8,2320 SUBSY       R76
      ASC 8,2323 SUBSY       R77
* 
TABEN               EQU * 
* 
*  WARNING !!! DO NOT REARRANGE ORDER OF THE FOLLING TABLE
* 
DVS00 ASC 8,MUX             ** DVS00
SB.05 ASC 8,264X TRMNL L.CTU** DV.05
      ASC 8,264X TRMNL R.CTU** DV.05
      ASC 8,264X TRMNL DSPLY** DV.05
      ASC 8,264X TRMNL PRNTR** DV.05
      ASC 8,264X TRMNL EXTDV** DV.05
DV.12 ASC 8,LINE PRINTER    ** DV.12
DVA12 ASC 8,2607-2618 LP    ** DVA12
DVB12 ASC 8,2608A LP        ** DVB12
DVZ12 ASC 8,2608A (GRAPHICS)** DVZ12
DVA32 ASC 8,IC DISC         ** DVA32
DVC32 ASC 8,IC DISC (# 2)   ** DVC32
DVP32 ASC 8,MAC DISC (# 2)  ** DVP32
DVP43 ASC 8,POWER FAIL      ** DVP43
DVA47 ASC 8,DATA ENTRY TRMNL** DVA47
DVR65 ASC 8,SERIAL LINK KIT ** DVR65
DVM72 ASC 8,UNIVERSAL INF.  ** DVM72
* 
TABAD DEF TABLE 
* 
S00.  ABS DVS00-TABEN+100B
.12.  ABS DV.12-TABEN+100B
A12.  ABS DVA12-TABEN+100B
B12.  ABS DVB12-TABEN+100B
Z12.  ABS DVZ12-TABEN+100B
A32.  ABS DVA32-TABEN+100B
C32.  ABS DVC32-TABEN+100B
P32.  ABS DVP32-TABEN+100B
P43.  ABS DVP43-TABEN+100B
A47.  ABS DVA47-TABEN+100B
R65.  ABS DVR65-TABEN+100B
M72.  ABS DVM72-TABEN+100B
* 
      SPC 2 
DVTYP NOP           DRIVER TYPE NUMBER
DSCRP NOP           RETURNED DESCRIPTION
NAME  NOP           TRUE DRIVER NAME
SUB   NOP           SUBCHANNEL
IODVC NOP      ENTRY POINT
      JSB .ENTR 
      DEF DVTYP 
      LDB DVTYP,I   GET THE DVR TYPE
      JSB SPECL      GO CHECK FOR SPECIAL TYPE
      BLF,BRS       MPY BY 8 TO GET OFFSET
      ADB TABAD     ADD TABLE ADDRESS 
      LDA M8        SET COUNTER TO MOVE 8 WDS 
      STA CNTR
LOOP  LDA B,I       START XFERING THE INFO
      STA DSCRP,I    AND SAVE IN USER BUFFER
      INB            BUMP ADDRESS 
      ISZ DSCRP 
      ISZ CNTR       AND COUNTER
      JMP LOOP      DONE YET ?
      JMP IODVC,I    YUP, RETURN
* 
B0    OCT 0 
B5    OCT 5 
B12   OCT 12
B32   OCT 32
B43   OCT 43
B47   OCT 47
B65   OCT 65
B72   OCT 72
B100  OCT 100 
M6    DEC -6
M8    DEC -8
M100B OCT -100
CNTR  NOP 
".    OCT 27000 
"A    OCT 40400 
"B    OCT 41000 
"C    OCT 41400 
"M    OCT 46400 
"P    OCT 50000 
"R    OCT 51000 
"S    OCT 51400 
"Z    OCT 55000 
HIBYT OCT 77400 
* 
SPECL NOP 
      ISZ NAME      SET UP FOR GETTING
      LDA NAME,I     SPECIAL LETTER 
      AND HIBYT 
      CPB B0        CHECK FOR THE MUX 
      JMP .D0 
      CPB B5        CHECK FOR THE MUX 
      JMP .D5 
      CPB B12       CHECK FOR LP
      JMP .D12       GO DOIT
      CPB B32 
      JMP .D32      CHECK FOR IC DISC 
      CPB B43       CHECK FOR SPOOL/POWER 
      JMP .D43
      CPB B47       DATA CAP ?
      JMP .D47       MAYBE
      CPB B65       OLD DS ?
      JMP .D65
      CPB B72       CHECK FOR UI/8940 
      JMP .D72
      JMP SPECL,I    NO SPECIALS RETURN 
* 
.D0   CPA "S        CHECK FOR THE MUX 
      LDB S00.
      JMP SCHK
* 
.D5   CPA "S        CHECK FOR THE MUX 
      LDB S00.
      LDA SUB,I     CHECK FOR SUBCHANNEL
      SZA,RSS 
      JMP SCHK      NO SUB FOR THIS ONE 
      ADA M6         CHECK FOR CRAZY
      SSA,RSS         SUBCHANNEL
      JMP SCHK      NO, GO DO IT. 
      LDA SUB,I 
      LDB S00.
      ALF,ARS       MULTIPLY BY 8 
      ADB A 
      JMP SCHK
* 
.D12  CPA "A        CHECK FOR DVA12 
      LDB A12.       RETURN WITH ADDRESS IN B 
      CPA "B        CHECK FOR DVB12 
      LDB B12.
      CPA "Z         CHECK FOR LOGICAL GRAPHICS 
      LDB Z12.
      CPA ".        CHECK FOR SPOOL MOD.
      LDB .12.
      JMP SCHK
* 
.D32  CPA "A        CHECK FOR IC DISC 
      LDB A32.
      CPA "C        CHECK FOR 2ND. ID DISC
      LDB C32.
      CPA "P         2ND. MAC DISC TOO. 
      LDB P32.
      JMP SCHK
* 
.D43  CPA "P
      LDB P43.       NO, GET PWR/FAIL 
      JMP SCHK     GO PROCESS 
* 
.D47  CPA "A        CHECK FOR DATA CAPP 
      LDB A47.
      JMP SCHK
* 
.D65  CPA "R        CHECK FOR OLD DS1B' 
      LDB R65.
      JMP SCHK
* 
.D72  CPA "M        DV'R'72 ? 
      LDB M72.      MUST BE UI CARD 
* 
SCHK  LDA B 
      AND M100B 
      SZA,RSS 
      JMP SPECL,I   NOT A SPECIAL 
      ADB M100B 
      BRS,BRS       DIVIDE BYE 8
      BRS 
      ADB B100      ADD BACK OFFSET 
      JMP SPECL,I    AND RETURN 
      END 
ASMB,L
 HED MAPIO SUBROUTINE TO RETRIEVE CONFIGURED RTE-IV MEMORY SIZE 
* 
      NAM MEMSZ,7             REV.2007 800211 
* 
      ENT MEMSZ 
      EXT .ENTR,$MATA,$MNP
* 
*************************** 
*                         * 
*   SOURCE: 02170-180XX   * 
*   RELOC.: 02170-160XX   * 
*                         * 
*************************** 
* 
*  DESCRIPTION
*  -----------
* 
*  THIS SUBROUTINE CALCULATES THE AMOUNT OF MEMORY CONFIGURED INTO
*  AN RTE-IV SYSTEM AND RETURNS THE VALUE TO THE CALLING PROGRAM AS 
*  THE DECIMAL NUMBER OF 1024-WORD PAGES. 
* 
*  CALLING SEQUENCE 
*  ---------------- 
* 
*   CALL MEMSZ(ISIZE) 
* 
*     ISIZE = THE ADDRESS OF THE RETURNED NUMBER 0F CONFIGURED PAGES
* 
* 
ISIZE NOP           THE ADDRESS PASSED BY THE CALLING PROGRAM 
* 
MEMSZ NOP           < ENTRY & EXIT POINT >
      JSB .ENTR     RETRIEVE ADDRESS WHERE MEMORY SIZE IS TO BE STORED
      DEF ISIZE 
* 
      LDA $MNP      GET MAXIMUM # OF PARTITIONS ALLOWED 
      CMA,INA       SET PARTITION ENTRY COUNTER 
      STA ENTRY     AND STORE 
* 
      LDB $MATA     GET ADDRESS OF MEMORY ALLOCATION TABLE. 
      ADB =D3       SET TO ADDRESS OF WORD THREE IN CURRENT ENTRY 
NEXT  LDA 1,I       LOAD PHYSICAL STARTING PAGE OF PARTITION
      SZA,RSS       A=0?
      JMP END       YES 
      AND PGMSK     INSURE PAGE NUMBER ONLY 
      STA ISTRT     NO,SAVE 
      INB           SET TO ADDRESS OF WORD 4 IN CURRENT ENTRY 
      LDA 1,I       LOAD NUMBER OF PAGES IN PARTITION 
      AND PGMSK     MAKE SURE PAGE ONLY 
      ADA ISTRT     AND ADD TO STARTING PAGE
      STA ISIZE,I   STORE MEMORY SIZE 
      ADB =D6       INCREMENT TO WORD 4 IN NEXT ENTRY 
      ISZ ENTRY     INCREMENT PARTITION COUNTER, SKIP IF 0
      JMP NEXT      TRY NEXT PARTITION ENTRY
* 
END   ISZ ISIZE,I   ADD ONE TO GET ACTUAL MEMORY SIZE 
      JMP MEMSZ,I   RETURN TO CALLER
* 
ENTRY NOP           PARTITION COUNTER 
ISTRT NOP           STARTING PHYSICAL PAGE NUMBER 
PGMSK OCT 1777      PAGE MASK FOR MAT ENTRY 
* 
      END 
ASMB,R,B,L
      NAM ISOL8,7 ISOLATE,RIGHT JUSTIFY BITS. 18 JAN 77.
      ENT ISOL8 
      EXT .ENTR 
* 
* I=ISOL8(J,11,8) ISOLATES BITS 11,10,9,8 FROM J AND RETURNS THEM 
*                 IN THE LEAST SIGNIFICANT BITS OF I. HIGH BITS OF
*                 I ARE ZEROED OUT. 
* I=ISOL8(J,8,11) DOES THE SAME THING.
* 
* I=ISOL8(J,15,0) RETURNS I=J 
* I=ISOL8(J,16,1) RETURNS I = J ROTATED 1 BIT RIGHT 
* 
J     NOP 
I1    NOP 
I2    NOP 
ISOL8 NOP 
      JSB .ENTR 
      DEF J 
      LDA I1,I
      CMA,INA      (A)= -I1 
      ADA I2,I     (A)= I2-I1 
      SSA          (A)>0 ?  I2>I1 ? 
      JMP RVERS    NO. I1>I2. 
      LDB I1,I     YES. I2>I1. GET I1.
      JMP CONT
RVERS LDB I2,I     I2 IS THE LEAST OF I1,I2.
      CMA,INA      (A)>=0.
CONT  CMB,INB      LEAST OF I1,I2 COUNTS ROTATIONS. 
      STA MASK#    MASK NUMBER >= 0.
      LDA J,I      GET THE WORD TO BE OPERATED ON.
* 
RLOOP SZB,RSS      DONE?  ROTATION COUNTER ROSE TO ZERO ? 
      JMP ISOL     YES. 
      RAR          NO. MOVE BITS-OF-INTEREST ONE PLACE RIGHT. 
      INB          BUMP ROTATION COUNTER. 
      JMP RLOOP 
* 
ISOL  LDB .MASK 
      ADB MASK#    (B) POINTS TO DESIRED MASK.
      AND B,I      ZERO OUT UNWANTED BITS.
      JMP ISOL8,I  RETURN WITH (A)=RIGHT JUSTIFIED ISOLATED BITS. 
* 
MASK# NOP 
.MASK DEF *+1 
      OCT 000001
      OCT 000003
      OCT 000007
      OCT 000017
      OCT 000037
      OCT 000077
      OCT 000177
      OCT 000377
      OCT 000777
      OCT 001777
      OCT 003777
      OCT 007777
      OCT 017777
      OCT 037777
      OCT 077777
      OCT 177777
* 
A     EQU 0 
B     EQU 1 
S     EQU 1 
      END