FTN4,L
      SUBROUTINE IDSGM(LU,IFMPT,ILU,IERR),92067-1X558 REV.2026 800131 
C 
C 
C     NAME:   IDSGM 
C     SOURCE: 92067-18558 
C     RELOC:  92067-16558 
C     PGMR:   R.D.
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     *
C  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
C  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
C  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
C  ***************************************************************
C 
      IMPLICIT INTEGER(A-Z) 
      DIMENSION INAM(3),MESG1(20),MESG2(22),MESG3(24),MESG4(10) 
      DATA MESG1/2HTH,2HE ,2HFO,2HLL,2HOW,2HIN,2HG ,2HPR,2HOG,2HRA,2HMS,
     &           2H H,2HAV,2HE ,2HID,2H S,2HEG,2HME,2HNT,2HS /
      DATA MESG2/2HPO,2HIN,2HTI,2HNG,2H T,2HO ,2HTH,2HE ,2HFM,2HP ,2HTR,
     &           2HAC,2HKS,2H Y,2HOU,2H'R,2HE ,2HRE,2HPL,2HAC,2HIN,2HG./
      DATA MESG3/2HTH,2HES,2HE ,2HPR,2HOG,2HRA,2HMS,2H M,2HUS,2HT ,2HBE,
     &           2H R,2HEM,2HOV,2HED,2H B,2HEF,2HOR,2HE ,2HRE,2HAD,2HT ,
     &           2HWI,2HLL/ 
      DATA MESG4/2HRE,2HPL,2HAC,2HE ,2HTH,2HE ,2HTR,2HAC,2HKS,2H. / 
C 
C     LU IS WHERE READT IS RESTORING THE FMP TRACKS LU 2 OR LU 3
C     IFMPT IS THE START OF THE FMP TRACKS
C     ILU IS THE LIST DEVICE. 
C     IERR = 0 WHEN THERE ARE NO ID SEGMENTS POINTING TO FMP TRACKS 
C              ON THE SPECIFIED DISC LU.
C     IERR <> 0  WHEN THERE ARE ID SEGMENTS.
C 
C 
C 
C     THIS SUBROUTINE SEARCHES THROUGH THE ID SEGMENTS VIA
C     THE KEYWORD TABLE.  ALL ID SEGMENTS THAT POINT TO FMP 
C     TRACKS WILL BE IDENTIFIED (LU 2 OR LU 3).  THIS 
C     WILL GIVE THE USER AN OPPORTUNITY TO "OF" ID SEGMENTS 
C     SO THAT ON A RESTORE OF LU 2 OR LU 3 THE SYSTEMS INTEGRITY
C     WILL BE MAINTAINED. 
C 
C 
C     GET FWA OF KEYWORD TABLE
C 
      IFWA=IXGET(1657B) 
C 
C     GET ID SEGMENT ADDRESS
C 
      ICNTR=-1
      IXERR=0 
C 
100   ICNTR=ICNTR+1 
C 
      IDSEG=IXGET(IFWA+ICNTR) 
C 
C     IF ENTRY IS 0 THEN EXIT (END OF TABLE). 
C 
      IF(IDSEG.EQ.0)GO TO 300 
C 
C 
C     GET PROGRAM NAME
C 
      INAM=IXGET(IDSEG+12)
      INAM(2)=IXGET(IDSEG+13) 
      INAM(3)=IXGET(IDSEG+14) 
C 
C     READ DISC ADDRESS FROM ID SEGMENT 
C     CHECK WHETHER IT'S LONG OR SHORT ID 
C 
      IOFF=26 
      IF ((IAND(INAM(3),20B)).NE.0) IOFF=19 
C 
C     IF PROGRAM TYPE IS ONE THEN CAN'T RESIDE ON FMP TRACKS
C 
      IF(IAND(INAM(3),17B).EQ.1)GO TO 100 
C 
C     GET DISC ADDRESS FROM ID SEGMENT
C 
      IDSCA=IXGET(IDSEG+IOFF) 
C 
      IF(LU.EQ.2)GO TO 200
C 
C     THIS IS A CHECK FOR ID SEGS. ON LU 3
C     IF BIT 15 IS 0 THEN DISC ADDR. IS ON LU 2 
C     OR IF THE DISC ADDR. IS LESS THAN THE START OF THE FMP TRACKS,
C      GET ANOTHER ID SEGMENT.
C 
      IF(IAND(IDSCA,100000B).EQ.0)GO TO 100 
C 
C     IDSCA=(IAND(77600B,IDSCA))/128
C 
      IF(IDSCA.LT.IFMPT)GO TO 100 
C 
C     KEEP CHECK OF ID SEGS. POINTING TO FMP TRACKS 
C     IF THERE AREN'T ANY RETURN IERR=0 
C     OTHERWISE IERR <> 0 
C 
C 
C     FOUND AN ID SEGMENT - PRINT PROGRAM NAME
C 
C     PAD FIRST SEVEN BITS OF THIRD WORD IN PROGRAM NAME. 
      IF(IXERR.NE.0)GO TO 170 
C 
      CALL EXEC(2,ILU,MESG1,20) 
      CALL EXEC(2,ILU,MESG2,22) 
      CALL EXEC(2,ILU,MESG3,24) 
      CALL EXEC(2,ILU,MESG4,10) 
C 
      IERR=-1 
C 
170   IXERR=IXERR+1 
C 
C 
      INAM(3)=IOR(IAND(77400B,INAM(3)),40B) 
C 
      CALL EXEC(2,ILU,INAM,3) 
C 
C     GET ANOTHER ID SEGMENT
C 
      GO TO 100 
C 
C     THIS IS THE CHECK OF ID SEGS. POINTING TO FMP TRACKS ON LU 2
C 
C     IF THE BIT 15 IS 1,THEN DISC ADDR. POINTS TO LU 3 
C     THEREFORE DON'T BOTHER TO LOOK. 
C 
200   IF(IDSCA.LT.0)GO TO 100 
C 
      IDSCA=(IAND(77600B,IDSCA))/128
C 
      IF(IDSCA.LT.IFMPT)GO TO 100 
C 
C     KEEP CHECK OF ID SEGS. POINTING TO FMP TRACKS ON LU 2 
C     IF THERE AREN'T ANY, RETURN IERR=0
C     OTHERWISE IERR <> 0 
C     PRINT PROGRAM NAME
C     PAD THIRD WORD OF PROGRAM NAME WITH A BLANK 
C 
      INAM(3)=IOR(IAND(77400B,INAM(3)),40B) 
C 
C     GIVE MESSAGE TO REMOVE ID SEGMENTS
C 
      IF(IXERR.NE.0)GO TO 220 
C 
      CALL EXEC(2,ILU,MESG1,20) 
      CALL EXEC(2,ILU,MESG2,22) 
      CALL EXEC(2,ILU,MESG3,24) 
      CALL EXEC(2,ILU,MESG4,10) 
C 
      IERR=-1 
C 
C 
220   IXERR=IXERR+1 
C 
      CALL EXEC(2,ILU,INAM,3) 
C 
C     GET ANOTHER ID SEGMENT
C 
      GO TO 100 
C 
C 
300   RETURN
      END 
                            