ASMB,Q,C
      HED <PGMAD> I.D. SEG. ADDRESS ROUTINE *(C) HEWLETT-PACKARD CO. 1980*
      NAM PGMAD,30 91750-1X145 REV.2013 800419 MEF
      ENT PGMAD 
      EXT .CBT,.LBT,.MBT,.MVW,.SBT,.ENTP,$LIBR,$LIBX,$OPSY
      SUP 
*    NAME:   PGMAD
*    SOURCE: 91750-18145
*    RELOC:  91750-1X145
*    PGMR:   C.C.H. [ 04/19/80 ]
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     *
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
*  ***************************************************************
*  PGMAD ACCEPTS A USER-SUPPLIED ADDRESS OF A 3-WORD ARRAY WHICH
*    CONTAINS THE ASCII CODE FOR THE NAME OF A PARTICULAR PROGRAM.
*    OPTIONALLY, IF THE FIRST WORD OF THE ARRAY IS A ZERO, THIS INDICATES 
*    A REQUEST TO RETURN THE ASCII NAME, ETC. FOR THE CALLING PROGRAM.
*  PGMAD RETURNS THE I.D. SEGMENT ADDRESS OF THE PROGRAM, THE STATUS, 
*    AN INDICATION OF THE TYPE OF I.D. SEGMENT (I.E.,LONG/SHORT), AND THE 
*    FATHER'S I.D. SEGMENT ADDRESS./
*  A DORMANT PROGRAM, ALSO IN THE TIME LIST, HAS STATUS SET =100000B. 
*  >>CAUTION: SHORT ID ADDRESS REPORTED= +(ADDRESS-13B) [KEY WORD FORMAT].
* 
*  IF THE USER SUPPLIES A NEGATIVE I.D. SEGMENT ADDRESS VIA PARAMETER 
*    'IDAD', THEN PGMAD WILL RETURN RETURN 3 WORDS, CONTAINING THE
*    ASCII PROGRAM NAME, TO THE BUFFER DEFINED BY THE 'NAME' PARAMETER. 
*  >>CAUTION: SHORT ID ADDRESS MUST BE= -(ID ADDR.-13B) [KEY WORD FORMAT].
* 
*  PGMAD CALLING SEQUENCE:
* 
*     JSB PGMAD 
*     DEF *+2  [ OR *+2+N WHERE N= NUMBER OF OPTIONAL PARAMETERS ]
*     DEF NAME      ADDRESS OF 3-WORD ASCII PROGRAM NAME ARRAY. 
*    [DEF IDAD]     [OPT. IF PARAM NEG: ASCII RETURNED; ELSE,0/+(ID ADDR)]
*    [DEF ISTAT]    [OPTIONAL ADDRESS FOR RETURN OF PROGRAM STATUS] 
*    [DEF IDTYP]    [OPTIONAL ADDRESS FOR RETURN OF I.D.SEGMENT TYPE] 
*    [DEF FATHA]    [OPTIONAL ADDRESS FOR RETURN OF FATHER'S I.D. ADDRESS]
*  <NORMAL RETURN>  <A> = I.D. SEGMENT ADDRESS. 
*                   <B> = PROGRAM STATUS. [ DORMANT, IN TIME LIST =100000B] 
*                   <E> = 0: STANDARD I.D. SEGMENT. 
*                   <E> = 1: SHORT I.D. SEGMENT.
* 
*  FORTRAN CALLING SEQUENCE: CALL PGMAD(NAME [,IDAD [,ISTAT [,IDTYP]]]) 
* 
*  PGMAD ERROR DETECTION: 
* 
*    A. ADDRESS OF NAME-ARRAY NOT SUPPLIED. 
*    B. CHARACTER #5 OF USER-SUPPLIED PROGRAM NAME IS NULL. 
*    C. I.D. SEGMENT WITH EQUIVALENT PROGRAM NAME CANNOT BE FOUND.
* 
*    -- RETURN TO <NORMAL RETURN> WITH: 
*       1. <A> & <B> AND 'IDAD' & 'ISTAT' ALL SET = 0.
*       2. <E> AND 'IDTYP' ARE SET =1.
      SKP 
NAME  NOP           POINTER TO ASCII NAME ARRAY.
P1    DEF A         POINTER FOR RETURN OF ID SEG. ADDRESS.
P2    DEF B         POINTER FOR RETURN OF PROGRAM STATUS. 
P3    DEF TEMP      POINTER FOR RETURN OF ID SEG. TYPE. 
P4    DEF TEMP+1    POINTER FOR RETURN OF FATHER ID ADDRESS.
PGMAD NOP           ENTRY/EXIT
      JSB $LIBR 
      NOP            OF THIS SUBROUTINE.
      JSB .ENTP     OBTAIN DIRECT ADDRESSES.
      DEF NAME      DEFINE PARAMETER STORAGE AREA.
FIRST JMP CONFG     CONFIGURE IF DMS, THEN FIRST =NOP.
      LDA NAME      GET THE ADDRESS OF THE ASCII ARRAY. 
      SZA,RSS       DID THE CALLER SUPPLY AN ADDRESS? 
      JMP ERREX       NO--ERROR!
* 
      CLE,ELA       FORM A BYTE ADDRESS 
      STA NAMBA     FOR THE USER'S ASCII BUFFER.
      SPC 1 
*    RESET POINTERS TO ALLOW USER TO CALL WITHOUT RETURN-DATA PARAMETERS. 
      SPC 1 
      DLD P1        GET PARAMETER ADDRESSES-IF ANY. 
      DST IDAD      SAVE FOR DATA RETURN. 
      DLD REGDF     GET INITIAL PARAMETER DEFINITION
      DST P1          AND RE-INITIALIZE FOR NO PARAMETERS.
      DLD P3        GET 'IDTYP' & 'FATHA' ADDRESSES--IF ANY.
      DST IDTYP     SAVE PARAMETER ADDRESSES. 
      DLD DTEMP     GET DEF'S TO DUMMY PARAMETER STORAGE. 
      DST P3        RE-SET FOR NO 'IDTYP' & 'FATHA' PARAMS. 
      INB           INITIALIZE I.D. POINTER 
      STB KEYPT      TO TEMPORARY STORAGE.
      CLA 
      LDA IDAD,I    GET THE ID ADDRESS--IF ANY. 
      CMA,SSA,INA   IF THE ADDRESS IS NOT NEGATIVE, 
      JMP ASCNM      THEN, USER IS SUPPLYING THE ASCII NAME.
      SPC 1 
*    DETERMINE ASCII PROGRAM NAME FROM USER'S I.D. SEGMENT ADDRESS. 
      SPC 1 
SEGAD STA IDSEG     SAVE I.D. SEGMENT ADDRESS.
      LDB KEYWD     GET KEYWORD TABLE ADDRESS.
KEYCK LDA B,I       GET THE KEYWORD ENTRY. [DMS: XLA B,I] 
      NOP 
      SZA,RSS       IF THIS IS THE ENO OF THE TABLE,
      JMP ERREX      THEN TELL THE CALLER OF HIS ERROR! 
* 
      CPA IDSEG     IF THE USER'S IS A VALID I.D. SEGMENT,
      JMP GETNM      THEN CONTINUE PROCESSING THE REQUEST.
      INB             ELSE, ADVANCE TO THE NEXT ENTRY,
      JMP KEYCK        AND CONTINUE THE SEARCH. 
* 
GETNM JSB GETID     MOVE NEEDED ID INFO TO LOCAL BUFFER.
      LDA LOCBA     GET SOURCE BYTE ADDRESS.
      LDB NAMBA     GET USER BUFFER BYTE ADDRESS. 
      JSB .MBT      MOVE THE FIVE 
      DEF D5         NAME CHARACTERS
      NOP             TO THE USER'S BUFFER. 
      LDA B40       PAD THE LAST WORD 
      JSB .SBT       WITH AN ASCII SPACE. 
      JMP ESTAT     COMPLETE THE PROCESSING.
      SPC 1 
*    DETERMINE I.D. SEGMENT ADDRESS FROM USER'S ASCII PROGRAM NAME. 
      SPC 1 
ASCNM LDA XEQT      GET CALLER'S I.D. SEGMENT ADDRESS.
      LDB NAME,I    IF THE CALLER SPECIFIED 
      SZB,RSS        ZERO AS THE FIRST ASCII NAME 
      JMP SEGAD       PARAMETER, THEN RETURN DATA ON CALLER.
* 
      LDB KEYWD     GET ADDRESS OF KEYWORD TABLE. 
      STB KEYPT     SET POINTER TO TOP OF TABLE.
PLOOP LDA B,I       GET KEYWORD-TABLE ENTRY. [DMS: XLA B,I] 
      NOP 
      SZA,RSS       IF THIS IS THE END-OF-LIST (0), 
      JMP ERREX       THEN GO TO RETURN AN ERROR INDICATION.
* 
      STA IDSEG     SAVE CURRENT ID SEGMENT ADDRESS.
      JSB GETID     MOVE NEEDED ID INFO TO LOCAL BUFFER.
      LDA LOCBA     GET BYTE ADDR. OF I.D. SEG NAME ENTRY.
      LDB NAMBA     GET BYTE ADDRESS OF USER'S BUFFER.
      JSB .CBT      COMPARE THE FIVE CHARACTER BYTE STRING. 
      DEF D5
      NOP 
      JMP ESTAT     NAME COMPARES. GO ESTABLISH STATUS ADDR.
      NOP           DOES NOT COMPARE. 
      ISZ KEYPT     NO COMPARISON. POINT TO NEXT ENTRY. 
      LDB KEYPT     GET NEXT KEYWORD TABLE ADDRESS. 
      JMP PLOOP     GO TO CHECK NEXT KEYWORD ENTRY. 
* 
ESTAT LDA PSTAT     GET STATUS WORD FROM LOCAL ID COPY. 
      AND B17       ISOLATE THE STATUS CODE (BITS# 4-0).
      CCE,SZA       IF STATUS IS NON-DORMANT (#0) 
      JMP SVST       TIME LIST CHECKING IS NOT REQUIRED.
      LDB TBIT      GET COPY OF 'T-BIT' WORD. 
      BLF,SLB       POSITION 'T' BIT AND TEST IT. 
      ERA           PROGRAM IN TIME LIST: STATUS =100000B.
SVST  STA PSTAT     SAVE THE MASKED STATUS CODE.
* 
      LDB FBYTA     GET BYTE ADDRESS OF FATHER POINTER. 
      JSB .LBT       AND GET THE ID NUMBER. 
      SZA,RSS       IF IT'S =0, NO FURTHER EFFORT NEEDED, 
      JMP SVDAD      SO SKIP TO RETURN 0 TO THE CALLER. 
      STA B         MOVE FATHER INDEX TO <B>. 
      ADB M1        COMPUTE THE FATHER'S ID SEGMENT ADDRESS 
      ADB KEYWD      FROM AN OFFSET INTO THE KEYWORD TABLE. 
DMS1  LDA B,I       GET KEYWORD TABLE ENTRY.[DMS: XLA B,I]
      NOP 
SVDAD STA FATHA,I   RETURN THE FATHER'S ID TO THE CALLER. 
* 
      LDA TYPID     GET WORD WITH SEGMENT SIZE (SS) FLAG. 
      LSR 4         RTE-M,III,IV 'SS' BIT IS WORD#15 BIT#4. 
      CLE,ERA       SET <E> TO: 0-LONG/1-SHORT ID.SEG. TYPE.
      CLA,SEZ       IF STANDARD I.D. SEG.: <A>=0; ELSE, 
      INA             SET <A>=1 FOR SHORT I.D. SEGMENT. 
      STA IDTYP,I   RETURN THE I.D. SEGMENT TYPE. 
      LDA IDSEG     <A> = I.D. SEGMENT ADDRESS. 
      CLB,SEZ       <B> = 0, IF THIS IS SHORT ID. SEG.
      STB FATHA,I   NO PATRIARCH FOR SHORT ID'S.
      SEZ,RSS       IF THIS IS A LONG ID SEGMENT: 
      LDB PSTAT     <B> = PROGRAM'S CURRENT STATUS. 
* 
EROUT STA IDAD,I    RETURN DATA TO
      STB ISTAT,I     USER'S PARAMETERS--IF ANY.
      JSB $LIBX     RETURN TO THE CALLER
      DEF PGMAD      VIA THE PRIVILEGED PROCESSOR.
* 
ERREX CLA,CCE,INA   SET 'IDTYP' & <E> 
      STA IDTYP,I     TO 1--FOR ERROR RETURN. 
      CLA           RETURN WITH <A> & <B> AND 'IDAD' &
      CLB             'ISTAT' ALL SET TO ZERO!
      JMP EROUT     GO TO RETURN THE BAD NEWS.
* 
GETID NOP           <A>= ID SEGMENT ADDRESS.
      ADA D12       POINT TO WORD #13 (NAME). 
      LDB LOCAD     DESTINATION IS LOCAL ID BUFFER. 
DMS2  JMP SAMAP     NON-DMS: BYPASS; DMS =NOP.
      LDX D9        MOVE 9 WORDS FROM ACTUAL ID SEGMENT,
      MWF            INTO THE LOCAL BUFFER. 
      JMP GETID,I   RETURN. 
SAMAP JSB .MVW      COPY PART OF
      DEF D9         THE ID SEGMENT 
      NOP             WITHOUT CROSS-MAP OPERATIONS. 
      JMP GETID,I   RETURN. 
* 
      SKP 
***** DO NOT CHANGE THE ORDER OF THE FOLLOWING STATEMENTS ***** 
* 
A     EQU 0 
B     EQU 1 
B17   OCT 17
B40   OCT 40
D5    DEC 5 
D9    DEC 9 
D12   DEC 12
M1    DEC -1
REGDF DEF A         DUMMY POINTER: PARAMETER #1.
      DEF B         DUMMY POINTER: PARAMETER #2.
DTEMP DEF TEMP      DUMMY POINTER: PARAMETER #3.
      DEF TEMP+1    DUMMY POINTER: PARAMETER #4.
FBYTA DBR FATHR     BYTE ADDRESS: LOCAL ID FATHER POINTER.
LOCAD DEF TEMP+3    ADDRESS OF LOCAL ID COPY'S NAME BYTES.
LOCBA DBL TEMP+3    BYTE ADDRESS OF LOCAL ID NAME BYTES.
IDAD  NOP           ADDRESS FOR RETURN OF I.D. SEG. ADDRESS.
ISTAT NOP           ADDRESS FOR RETURN OF PROGRAM STATUS. 
IDTYP NOP           ADDRESS FOR RETURN OF I.D. SEGMENT TYPE.
FATHA NOP           ADDRESS FOR RETURN OF FATHER ID SEG. NO.
KEYPT NOP           POINTER TO CURRENT I.D. SEGMENT ADDRESS.
TEMP  BSS 13        TEMPORARY BUFFER: PARAMS AND ID SEGMENT.
IDSEG EQU TEMP+2    POINTER TO ID SEG ADDRESS.
TYPID EQU TEMP+5    POINTER TO ID TYPE 'SS' BIT, IN LOCAL ID. 
PSTAT EQU TEMP+6    POINTER TO STATUS WORD, IN LOCAL ID COPY. 
TBIT  EQU TEMP+8    POINTER TO 'T' BIT (TIME LIST). 
FATHR EQU TEMP+11   POINTER TO FATHER INDEX.
NAMBA EQU TEMP+12   POINTER TO NAME ARRAY BYTE ADDRESS. 
KEYWD EQU 1657B     BASE PAGE POINTER TO KEYWORD TABLE. 
XEQT  EQU 1717B     CURRENTLY EXECUTING ID ADDRESS. 
* 
*    DMS CONFIGURATION--FIRST PASS, ONLY. 
* 
      ORG IDAD      CODE IN BUFFER TO SAVE SPACE. 
CONFG CLB 
      LDA $OPSY     GET OP-SYSTEM IDENTIFIER. 
      RAR,SLA       DMS SYSTEM? 
      STB DMS2       YES, CLEAR PATH TO 'MWF' INSTRUCTION.
      STB FIRST     PREVENT RE-EXECUTION OF THIS CODE.
      SLA,RSS       DMS SYSTEM? 
      JMP FIRST+1    NO, RETURN TO MAIN CODE. 
      DLD XLABI      YES, CONFIGURE 
      DST KEYCK        INSTRUCTIONS 
      DST PLOOP         FOR CROSS-MAP 
      DST DMS1           OPERATIONS.
      JMP FIRST+1   RETURN. 
* 
XLABI XLA B,I 
* 
      ORR 
* 
      END