ASMB,Q,C
      HED IDADL: 91750-1X127 REV 2013 (C) HEWLETT-PACKARD CO. 1980
      NAM IDADL,8 91750-1X127 REV 2013 791119 L 
* 
      SPC 2 
******************************************************************
*  * (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 THE HEWLETT-PACKARD COMPANY.   *
******************************************************************
      SPC 4 
****************************************************************
* 
*     NAME:         IDADL 
*     SOURCE:       91750-18127 
*     RELOC:        91750-1X127 
*     PGMR:         DAN GIBBONS 
* 
*************************************************************** 
      SPC 2 
      ENT #IDAD 
      EXT $IDSZ,$IDA
* 
*     THIS SUBROUTINE ACCEPTS AN RTE-L FILE DIRECTORY OPEN- 
*     FLAG (CONTAINING EXCLUSIVE OPEN FLAG IN BIT 15 AND IDSEG
*     # IN RIGHT BYTE) IN THE A-REG, AND CONVERTS IT TO THE 
*     FORMAT USED BY M & PRE-RTE4B SYSTEMS (BIT 15 UNCHANGED, 
*     BITS 0-14 = IDSEG ADDRESS). 
* 
* 
*     CALLING SEQUENCE: 
* 
*             <A> = L-TYPE OPEN FLAG
*             JSB #IDAD 
*             RETURN--<A>=M/RTE4B-TYPE OPEN FLAG, <B> DESTROYED 
* 
      SKP 
#IDAD NOP           <A>=L-TYPE OPEN FLAG
      STA TEMP      SAVE IT 
      AND RTBYT     ISOLATE IDSEG # 
      SZA,RSS       ANY IDSEG #?
      JMP #IDAD,I   NO, RETURN WITH <A>=0 
      ADA M1
      MPY $IDSZ     <A>=(IDSEG#-1)(IDSEG SIZE)
      ADA $IDA      ADD STARTING ADR OF IDSEGS
      LDB TEMP      RETRIEVE ORIGINAL OPEN FLAG 
      ELB           <E>=EXCLUSIVE OPEN BIT
      RAL,ERA       SET IT INTO BIT 15
      JMP #IDAD,I   RETURN. <A>=ALTERNATE TYPE OPEN FLAG
      SPC 3 
TEMP  NOP 
RTBYT OCT 377 
M1    DEC -1
      END 
                                                                                                                          