ASMB,R,L,C
      HED "MYNAM" ROUTINE TO FIND PROGRAMS NAME 7-76 (DLB)
*     NAM MYNAM,7 PRE-REL 7-6-76 (DLB)
*     NAM MYNAM,7 09570-16518 REV. A 761013 
      NAM MYNAM,7 PRE-REL 780330 (DLB) RTE-IV 
      ENT MYNAM 
      EXT .ENTR,.XLA
      SPC 1 
* 
*-------------------------------------------------------- 
* 
*     RELOC.       09570-16518
*     SOURCE       09570-18518
* 
*     D. L. BASKINS      13 OCT 76 REV. A 
* 
*-------------------------------------------------------- 
B     EQU 1 
XEQT  EQU 1717B 
*  PURPOSE: 
*    THIS ROUTINE WILL RETURN THE CURRENT EXECUTING PROGRAMS'S NAME 
*    (THE CALLER) IN A 3 WORD CALLERS BUFFER WITH A TRAILING ASCII
*    SPACE.  IT WILL ALSO RETURN THE PROGRAMS ID SEGMENT ADDRESS IN 
*    A-REGISTER.
*  CALLED:
*    DIMENSION NAMEBF(3)
*    IDADR = MYNAM(NAMEBF)
*        -OR- 
*    CALL MYNAM(NAMEBF) 
*   WHERE:  NAMEBF = THREE WORD BUFFER THAT NAME IS RETURNED
*           IDADR  = IDSEGMENT ADDRESS OF PROGRAM 
*  TEST PROGRAM:
*FTN,L
*      PROGRAM TEST 
*      DIMENSION NAMEBF(3)
*      IDADR = MYNAM(NAMEBF)
*      WRITE (1,100) NAMEBF,IDADR 
*  100 FORMAT("THE NAME OF THIS PROGRAM IS "3A2"WITH AN ID ADDRESS" 
*     1" OF "@6"B") 
*      STOP 
*      END
      SPC 1 
TEMP1 NOP 
MYNAM NOP           ENTRY 
      JSB .ENTR     GET CALLERS PARAMETERS
      DEF TEMP1 
      LDB XEQT      GET IDSEG ADDRESS OF THIS PROGRAM 
      ADB D12       BUMP TO NAME BUFFER 
      JSB .XLA
      DEF B,I 
*     LDA B,I       GET 1ST TWO CHARACTORS OF NAME
      STA TEMP1,I   SAVE IN CALLERS BUFFER
      INB           BUMP TO NEXT WORD 
      ISZ TEMP1     BUMP TO NEXT DEST WORD
      JSB .XLA
      DEF B,I 
*     LDA B,I       GET NEXT 2 CHARACTORS IN BUFFER 
      STA TEMP1,I   PUT IN CALLERS BUFFER 
      INB 
      ISZ TEMP1 
      JSB .XLA
      DEF B,I 
*     LDA B,I       GET LAST WORD IN BUFFER 
      AND OM400     MASK OFF LAST CHARACTOR 
      IOR O40       AND MIRGE IN SPACE
      STA TEMP1,I   AND PUT IN CALLERS BUFFER 
      LDA XEQT      RETURN WITH ID ADDRESS IN A-REG 
      JMP MYNAM,I 
      SPC 1 
OM400 OCT -400
D12   DEC 12
O40   OCT 40
      END 
                                                                                                        