ASMB,R,L,C,N
      HED <PGMAD> I.D. SEG. ADDRESS ROUTINE *(C) HEWLETT-PACKARD CO. 1976*
      IFN 
      NAM PGMAD,7 91700-16152 REV.A 760117
      EXT .ENTR 
      XIF 
      IFZ 
      NAM PGMAD,14 91700-16152 REV.A 760117 
      EXT .ENTP,$LIBR,$LIBX 
      XIF 
      ENT PGMAD 
      SPC 1 
*    NAME:   PGMAD
*    SOURCE: 91700-18152
*    RELOC:  91700-16152
*    PGMR:   C.C.H. [ 01/17/76 ]  [LIBERALLY EXTRACTED FROM 'SCHED']
      SPC 1 
******************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976.  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.       *
******************************************************************
      SPC 1 
*  PGMAD ACCEPTS A USER-SUPPLIED ADDRESS OF A 3-WORD ARRAY WHICH
*    CONTAINS THE ASCII CODE FOR THE NAME OF A PARTICULAR PROGRAM.
*  PGMAD RETURNS THE I.D. SEGMENT ADDRESS OF THE PROGRAM, IT'S STATUS,
*    AND AN INDICATION OF THE TYPE OF I.D. SEGMENT; I.E.,LONG/SHORT.
* 
*  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]     [OPTIONAL ADDRESS FOR RETURN OF I.D. SEG. ADDRESS]
*    [DEF ISTAT]    [OPTIONAL ADDRESS FOR RETURN OF PROGRAM STATUS] 
*    [DEF IDTYP]    [OPTIONAL ADDRESS FOR RETURN OF I.D.SEGMENT TYPE] 
*  <NORMAL RETURN>  <A> = I.D. SEGMENT ADDRESS. 
*                   <B> = PROGRAM STATUS. 
*                   <E> = 0: STANDARD 28-WORD I.D. SEGMENT. 
*                   <E> = 1: SHORT(PROGRAM SEGMENT) 9-WORD I.D. SEGMENT.
* 
*  FORTRAN CALLING SEQUENCE: CALL PGMAD(NAME [,IDAD [,ISTAT [,IDTYP]]]) 
*                                          OR 
*                            REG=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.
* 
NAME  NOP           ADDRESS OF ASCII NAME ARRAY.
P1    DEF A         ADDRESS FOR RETURN OF PARAMETER #1. 
P2    DEF B         ADDRESS FOR RETURN OF PARAMETER #2. 
P3    DEF PTEM      ADDRESS FOR RETURN OF PARAMETER #3. 
      SUP           [SUPPRESS EXTENDED LISTING] 
PGMAD NOP           ENTRY/EXIT: I.D.SEG. ADDRESS ROUTINE. 
      IFN 
      JSB .ENTR     OBTAIN DIRECT ADDRESSES.
      XIF 
      IFZ 
      JSB $LIBR     DEFINE THIS SUBROUTINE
      NOP             TO BE PRIVILEGED. 
      JSB .ENTP     GET DIRECT ADDRESSES--PRIVILEGED MODE.
      XIF 
      DEF NAME      DEFINE PARAMETER STORAGE AREA.
      SPC 1 
      LDA NAME      GET THE ADDRESS OF THE ASCII ARRAY. 
      SZA,RSS       DID THE CALLER SUPPLY AN ADDRESS? 
      JMP ERREX       NO--ERROR!
      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.
      LDA P3        GET 'IDTYP' PARAMETER ADDRESS--IF ANY.
      LDB DPTEM     GET DEF TO DUMMY PARAMETER STORAGE. 
      STA IDTYP     SAVE PARAMETER ADDRESS. 
      STB P3        RE-INITIALIZE FOR NO 'IDTYP' PARAMETER. 
* 
      LDB NAME      GET ADDRESS OF NAME ARRAY.
      STB PTEM      SAVE ADDRESS OF 1RST & 2ND CHARACTERS.
      INB           POINT TO 2ND TWO CHARS. OF NAME ARRAY.
      STB PTEM+1    SAVE ADDRESS OF 3RD & 4TH CHARS.
      INB           POINT TO LAST CHARACTER'S ADDRESS.
      LDA B,I       GET THE WORD FROM THE NAME ARRAY. 
      AND UBYTE     ISOLATE CHAR.#5 FROM UPPER BYTE.
      STA PTEM+2    SAVE CHAR.#5 LOCALLY. 
      SZA           FORCE ERROR-RETURN FOR A NULL CHARACTER.
      LDA KEYWD     GET ADDRESS OF KEYWORD TABLE. 
      STA KEYPT     SET POINTER TO TOP OF TABLE.
PLOOP LDA KEYPT,I   GET THE KEYWORD-TABLE ENTRY.
      CCE,SZA,RSS   IF THIS IS THE END-OF-LIST (0), 
      JMP ERREX       THEN GO TO RETURN AN ERROR INDICATION.
* 
      ADA P12       POINT TO NAME-CHARS.1 & 2 IN I.D. SEG.
      LDB A,I       GET CHARS. 1 & 2 FROM I.D. SEGMENT. 
      CPB PTEM,I    IF THEY ARE THE SAME AS USER'S CHARS.,
      INA,RSS         THEN PROCEED WITH COMPARISON; ELSE, 
      JMP PNEXT         GO TO GET NEXT KEYWORD ENTRY. 
* 
      LDB A,I       GET CHARS. 3 & 4 FROM THE I.D. SEGMENT. 
      CPB PTEM+1,I  IF THESE TWO COMPARE TO USER'S CHARS, 
      INA,RSS         THEN CONTINUE CHECKING; ELSE, 
      JMP PNEXT         GO TO GET NEXT KEYWORD ENTRY. 
* 
      STA PSTAT     SAVE ADDRESS TO GET STATUS--LATER.
      LDA A,I       GET THE LAST CHAR. FROM I.D. SEGMENT. 
      STA B         SAVE THE WORD FOR SHORT I.D. TESTING. 
      AND UBYTE     ISOLATE CHARACTER #5 FROM I.D. SEG. 
      CPA PTEM+2    IF THIS IS A FINAL MATCH, THEN
      JMP PFOUN       GO TO GATHER DATA FOR THE RETURN. 
* 
PNEXT ISZ KEYPT     POINT TO NEXT KEYWORD ENTRY.
      JMP PLOOP     GO TO CHECK NEXT KEYWORD ENTRY. 
* 
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.
* 
PFOUN LSR 4         MOVE THE SHORT I.D. BIT TO <B#0>. 
      CLE,ERB       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 KEYPT,I   <A> = I.D. SEGMENT ADDRESS. 
      ISZ PSTAT     POINT TO I.D. SEGMENT STATUS WORD.
      LDB PSTAT,I   <B> = PROGRAM'S CURRENT STATUS. 
EROUT STA IDAD,I    RETURN DATA TO
      STB ISTAT,I     USER'S PARAMETERS--IF ANY.
      IFN 
      JMP PGMAD,I   RETURN TO CALLER. 
      XIF 
      IFZ 
      JSB $LIBX     RETURN TO CALLER
      DEF PGMAD       VIA PRIVILEGED PROCESSOR. 
      XIF 
* 
A     EQU 0 
B     EQU 1 
DPTEM DEF PTEM      DUMMY POINTER: PARAMETER #3.
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.
KEYPT NOP           POINTER TO CURRENT I.D. SEGMENT ADDRESS.
KEYWD EQU 1657B     BASE PAGE ADDRESS OF KEYWORD TABLE. 
P12   DEC 12        OFFSET TO I.D. SEGMENT NAME-ENTRY.
PSTAT NOP           TEMPORARY STORAGE.
PTEM  OCT 0,0,0     TEMPORARY STORAGE.
REGDF DEF A         DUMMY POINTER: PARAMETER #1.
      DEF B         DUMMY POINTER: PARAMETER #2.
UBYTE OCT 177400    UPPER-BYTE ISOLATION MASK.
      SPC 1 
      END 
                                                                            