FTN4
      SUBROUTINE TMGPU(IMAG,MAIN,M,N),92903-16403 REV.1913  781113
C 
C 
C     NAME:   TMGPU,KLPRG 
C     SOURCE: &TMGPU    92903-18403 
C     RELOC:  %TMGPU    92903-16403    PART OF  RTMGLB
C 
C     PGMR:   FRANCOIS GAULLIER   HPG 
C 
C 
C     **************************************************************
C     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  ALL RIGHTS    *
C     * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
C     * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
C     * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
C     **************************************************************
C 
C 
C     ****************************************************************
C     *                                                              *
C     *   THIS SUBROUTINE PURGE AND CLEAR ID-SEGMENT OF ALL          *
C     *   REQUESTED PROGRAM.                                         *
C     *                                                              *
C     *   CALL TMGPU(IMAG,MAIN,M,N)                                  *
C     *    IMAG  - .TRUE. IF IMAGE MODULE NEED TO REMOVED (FILES     *
C     *                      PURGED AND IDSEG CLEARED)               *
C     *    MAIN  - .TRUE. IF MAIN MODULES NEED TO BE REMOVED (FILES  *
C     *                      PURGED AND IDSEG CLEARED)               *
C     *    M     - NUMBER OF THE FIRST USER PARTITION TO REMOVE      *
C     *    M     - NUMBER OF THE LAST USER PARTITION TO REMOVE       *
C     *                                                              *
C     ****************************************************************
C 
C 
C-----LABEL COMMON # 1  GENERAL INFORMATION 
C 
      COMMON /TMGC1/LU,LUPRT
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IDUM0(7),NCRTH(1) 
C 
      DIMENSION NAME(3),IPUG(22),IMES(33) 
C 
      LOGICAL DODO,IMAG,MAIN
C 
      DATA IPUG/15530B,15555B,15446B,2Hk0,2HB ,15510B,15512B,15542B 
     .,2H  ,15446B,2HdC,2HPU,2HRG,2HE ,2HPH,2HAS,2HE ,15446B,2Hd@ 
     .,6412B,5012B,15554B/
      DATA IMES/6*2H  ,2HFI,2HLE,2HS ,2HPU,2HRG,2HED,13*2H  , 
     .     2HPR,2HOG,2HRA,2HMS,2H R,2HEM,2HOV,2HED/ 
C 
      IF (MAIN)  CALL EXEC(2,LU,IPUG,22)
C 
C-----STOP THE TMS APPLICATION
C 
      CALL MOVEW(NCRTH(5),NAME,2) 
      NAME(3)=2H
      CALL LURQ(100000B,0,0)
      CALL ETMSP(NAME,99) 
      CALL LURQ(1,LU,1) 
C 
C-----IF LIST LU IS NOT THE CRT, LOCK THE LIST LU 
C 
      CALL LCKLL(LU,LUPRT,500)
C 
C-----WRITE HEADER ON LIST DEVICE 
C 
      CALL EXEC(3,1100B+LUPRT,-1) 
      CALL EXEC(2,LUPRT,2H  ,-1)
      CALL EXEC(2,LUPRT,2H  ,-1)
      CALL EXEC(2,LUPRT,IMES,33)
      CALL EXEC(2,LUPRT,2H  ,-1)
      CALL EXEC(2,LUPRT,2H  ,-1)
C 
C-----GET RID OF USER PARTITION 
C 
      DO 100  I=N,M,-1
      NAME(3)=2H @+I
      CALL KLPRG(NAME,0)
100   CONTINUE
C 
C-----GET RID OF TMS-IMAGE MODULE 
C 
      IF ( .NOT. IMAG)  GO TO 200 
      IF(NCRTH(26) .EQ. 0)  GOTO 200
      J=27
      DO 130 I=1,NCRTH(26)
      CALL KLPRG(NCRTH(J+9),1)
130   J=J+15
C 
C-----GET RID OF TMST, TMSL AND TMS MAIN
C 
200   IF( .NOT. MAIN)  GOTO 500 
      NAME=2HL
      NAME(3)=2H
      CALL MOVCA(NCRTH,9,NAME,2,4)
      CALL KLPRG(NAME,0)
      CALL PUTCA(NAME,1HT,1)
      CALL KLPRG(NAME,0)
      CALL MOVEW(NCRTH(5),NAME,2) 
      NAME(3)=2H
      CALL KLPRG(NAME,0)
C 
C-----PURGE FILE  &XXXX 
C 
      CALL KLPRG(NAME,2)
C 
C-----END OF PURGE------------------------- 
C 
500   CALL EXEC(3,1100B+LUPRT,-1) 
C 
C-----IF LIST LU HAS BEEN LOCKED, UNLOCK IT 
      IF(LUPRT .NE. LU)  CALL LURQ(0,LUPRT,1) 
      RETURN
      END 
      SUBROUTINE KLPRG(NAME,IFLG),92903-16403 REV.1913  781113
C 
C 
C     ******************************************************************
C     *                                                                *
C     *  THIS SUBROUTINE PURGE AND REMOVE ID SEGMENT FOR ONE PROGRAM.  *
C     *                                                                *
C     *  CALL KLPRG(NAME,IFLG)                                         *
C     *                                                                *
C     *   NAME - NAME OF THE PROGRAM TO BE REMOVED,                    *
C     *   ILFG - FUNCTION                                              *
C     *                                                                *
C     *     IFLG                               FUNCTION                *
C     *     ----                              ----------               *
C     *                                                                *
C     *      0           PURGE FILES "%NAME",">NAME" AND "NAME"        *
C     *                  RELEASE ID-SEGMENT "NAME".                    *
C     *      1           PURGE FILES "%NAME",">NAME" AND "NAME"        *
C     *                  BUT CLEAR IDSEG. ONLY IF "NAME" IS DORMANT    *
C     *      2           PURGE FILES "&NAME" AND DO NOT                *
C     *                  CLEAR THE ID-SEGMENT "NAME".                  *
C     *                                                                *
C     ******************************************************************
C 
C 
      LOGICAL DORMT 
C 
C-----LABEL COMMON # 1  GENERAL INFORMATION 
C 
      COMMON /TMGC1/LU,LUPRT
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IDUM0(7),NCRTH(1) 
C 
      DIMENSION IREG(2),NAME(1),IDCB(144),NOM(4),IMES(32) 
C 
      INTEGER AREG,BREG 
      LOGICAL PURGE,IDCLR,PRINT 
C 
      EQUIVALENCE (REG,AREG,IREG),(IREG(2),BREG)
C 
      CALL BLANC(IMES,32) 
      PRINT=.FALSE. 
      J=4 
C 
C     SET UP FILE NAME
C 
      NOM=2H% 
      CALL MOVEW(NAME,NOM(2),3) 
      CALL ISUPB(NOM,4) 
      CALL MOVEW(NCRTH(7),AREG,2) 
      ASSIGN 50 TO IRTN 
      IF(IFLG .NE. 2)  GOTO 1000
      CALL PUTCA(NOM,1H&,1) 
      ASSIGN 200 TO IRTN
      GOTO 1000 
50    CALL PUTCA(NOM,1H>,1) 
      ASSIGN 60 TO IRTN 
      GOTO 1000 
60    CALL PUTCA(NOM,1H ,1) 
      CALL ISUPB(NOM,3) 
      IF(IFLG .EQ. 1)  GOTO 70
      AREG=0
      BREG=2
      ASSIGN 70 TO IRTN 
      GOTO 1000 
70    J=28
      ASSIGN 200 TO IRTN
      IF( .NOT. DORMT(NOM) )  GOTO 200
      IF( .NOT. IDCLR(NOM,IERR))  GOTO 1100 
      IF(IERR .EQ. -1)  GOTO IRTN 
      GOTO 1050 
C 
200   IF (PRINT) CALL EXEC(2,LUPRT,IMES,J-3)
      RETURN
C 
C     PURGE PROCESS 
C 
1000  IF( .NOT. PURGE(IDCB,IERR,NOM,AREG,BREG)) GOTO 1100 
      IF(IERR .EQ. -6)  GOTO IRTN 
1050  IMES(J-1)=2H <
      IMES(J+3)=2H> 
      IF(IERR .EQ. -7)  IMES(J+4)=2HSC
      IF(IERR .EQ. -2)  IMES(J+4)=2HDO
      IF(IERR .EQ. -3)  IMES(J+4)=2HSY
      IF(IERR .EQ. -4)  IMES(J+4)=2HPE
      IF(IERR .EQ. -5)  IMES(J+4)=2HCR
1100  CALL MOVEW(NOM,IMES(J),3) 
      CALL ISUPB(IMES(J),4) 
      IF(J.NE.4 .AND. J.NE.28)  IMES(J-2)=2H -
      PRINT=.TRUE.
      J=J+7 
      GOTO IRTN 
      END 
      END$
                                                                                                                                  