FTN4
      PROGRAM TMPG1(5),92080-16453 REV.2026  800314         
C 
C 
C     NAME: TMPG1 
C     SOURCE: &TMG1A    92080-18453 
C     BINARY: %TMG1A    92080-16453 
C 
C     PGMR: DANIEL POT/FRANCOIS GAULLIER   HPG
C 
C 
C     **************************************************************
C     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  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         *  THIS PROGRAM ALLOWS USER EITHER TO    *
C         *  LIST ALL FILES OF AN APPLICATION      *
C         *  OR TO LOAD ALL PROGRAMS ASSOCIATED    *
C         *  TO THIS APPLICATION.                  *
C         *                                        *
C         *   IF P1 = 0  FUNCTION LIST             *
C         *   IF P1 = 1  FUNCTION LOAD             *
C         ******************************************
C 
C 
C     STOP USED:  1000
C     ----------
C 
C     NOTE: WORKS ON PACKED FORM OF NCRTH 
C    ------ 
C 
C 
CCB1
C*********************************************************************
C 
C-----LABELED COMMON # 1  GENERAL INFORMATION 
C 
      COMMON /TMGC1/LU,LUPRT,LUOUT,ISYTP,IPARAM(5)
C 
C     LU     - USER TERMIAL LU
C     LUPRT  - LISTING LU 
C     LUOUT  - NOT USED 
C     ISYTP  - SYSTEM TYPE (MUST BE .EQ. -9, RTE-IV)
C     IPARAM - TMSGN OPERATING PARAMETERS:
C              ISCRN  - CURRENT SCREEN NO.
                        EQUIVALENCE (ISCRN,IPARAM(1)) 
C              IOFST  - OFFSET INTO BUFFER NCRTH
                        EQUIVALENCE (IOFST,IPARAM(2)) 
C              IEND   - INTERACTIVE OPERATION INDICATOR 
C                       0 - CURRENT PROCESS 
C                       1 - END OF PROCESS
C                       2 - ABORT TMSGN 
C                       3 - PREVIOUS SCREEN 
                        EQUIVALENCE (IEND,IPARAM(3))
C              IJOB   - TMS FUNCTION INDICATOR
C                       0 - DEFINE (INT. AND AUX. LU'S, AND T.U.S.) 
C                       1 - SCREEN HAS BEEN PRINTED, PERFORM ANALYSIS 
C                       3 - DEFINE T.U.S. INTO USER PARTITION 
                        EQUIVALENCE (IJOB,IPARAM(4))
C 
C*********************************************************************
CCB1
C 
C 
CCB3
C*********************************************************************
C 
C-----LABELED COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO 
     .             ,NCRTH(2540) 
C 
C     IREFC  -
C     ILUGH  -
C     INTMS  -
C     ILPRG  -
C     IDECL  -
C     ILGMX  -
C     NBPRO  -
C     NCRTH  - OUTPUT FILE BUFFER:
C              NCNOWD - NO. OF WORDS IN FILE
                        EQUIVALENCE (NCNOWD,NCRTH(1)) 
C              NCINLU - BUFFER ADDR OF INTERACTIVE LU TABLE 
                        EQUIVALENCE (NCINLU,NCRTH(2)) 
C              NCAXLU - BUFFER ADDR OF AUX LU TABLE 
                        EQUIVALENCE (NCAXLU,NCRTH(3)) 
C              NCPAR1 - BUFFER ADDR OF FIRST PARTITION
                        EQUIVALENCE (NCPAR1,NCRTH(4)) 
C              NCNAME - APPLICATION NAME (2 WDS)
                        DIMENSION NCNAME(2) 
                        EQUIVALENCE (NCNAME,NCRTH(5)) 
C              NCSCOD - SECURITY CODE 
                        EQUIVALENCE (NCSCOD,NCRTH(7)) 
C              NCCRNO - CARTRIDGE NO. 
                        EQUIVALENCE (NCCRNO,NCRTH(8)) 
C              NCEMAS - EMA SIZE IN KWDS
                        EQUIVALENCE (NCEMAS,NCRTH(9)) 
C              NCMSEG - MSEG SIZE IN KWDS 
                        EQUIVALENCE (NCMSEG,NCRTH(10))
C              NCPARS - PARTITION SIZE IN KWDS
                        EQUIVALENCE (NCPARS,NCRTH(11))
C              NCPARN - PARTITION NO. 
                        EQUIVALENCE (NCPARN,NCRTH(12))
C              NCLOGD - LOGGING DEVICE LU OR FILENAME (5 WDS) 
                        DIMENSION NCLOGD(5) 
                        EQUIVALENCE (NCLOGD(1),NCRTH(13)) 
C              NCTUSP - TUS NAME OF STARTING PROCESS (3 WDS)
                        DIMENSION NCTUSP(3) 
                        EQUIVALENCE (NCTUSP(1),NCRTH(18)) 
C              NCSTCK - STACK LENGTH
                        EQUIVALENCE (NCSTCK,NCRTH(21))
C              NCINIP - TUS NAME OF INITIAL PROCESS (3 WDS) 
                        DIMENSION NCINIP(3) 
                        EQUIVALENCE (NCINIP(1),NCRTH(22)) 
C              NCLUIN - LU FOR INITIAL PROCESS
                        EQUIVALENCE (NCLUIN,NCRTH(25))
C              NCDBNO - NO. OF DATA BASES 
                        EQUIVALENCE (NCDBNO,NCRTH(26))
C 
C NOTE: THE FOLLOWING VARIABLES ARE EQUIVALENCED TO "NCRTH" FOR USE 
C       BY TMSG5. 
C 
C              IEXFL  - 
                        EQUIVALENCE (IEXFL,NCRTH(2101)) 
C              IPTR   - 
                        EQUIVALENCE (IPTR,NCRTH(2102))
C              NBSCR  - 
                        EQUIVALENCE (NBSCR,NCRTH(2103)) 
C              IFSCR  - 
                        EQUIVALENCE (IFSCR,NCRTH(2104)) 
C              ILAST  - 
                        EQUIVALENCE (ILAST,NCRTH(2105)) 
C              IFLG   - 
                        DIMENSION IFLG(29)
                        EQUIVALENCE (IFLG(1),NCRTH(2106)) 
C              IPRVS  - 
                        DIMENSION IPRVS(29) 
                        EQUIVALENCE (IPRVS(1),NCRTH(2135))
C              IBUFR  - DATA BUFFER USED BY SUBROUTINE "TMPRS"
                        DIMENSION IBUFR(62) 
                        EQUIVALENCE (IBUFR(1),NCRTH(2164))
C              ITEMP  - 
                        DIMENSION ITEMP(3)
                        EQUIVALENCE (ITEMP(1),NCRTH(2226))
C              ITOSC  - 
                        EQUIVALENCE (ITOSC,NCRTH(2229)) 
C 
C*********************************************************************
CCB3
C 
C 
C 
      DIMENSION IBUF(350),NUMB(40),ILIS(20),IHEAD(40),MTMPR(28) 
      DIMENSION JTEMP(3),KTEMP(3) 
C 
      LOGICAL PRINT 
C 
      EQUIVALENCE (NCRT5,NCRTH(5))
C 
      DATA ILIS/15530B,15555B,15446B,2Hk0,2HB ,15542B,15510B,15512B 
     .,2H  ,15446B,2HdC,2HLI,2HST,2HIN,2HG ,15446B,2Hd@,6412B 
     .,5012B,15554B/
      DATA IHEAD/2H P,2HAG,2HE ,2H00,2H01,2H  ,2H D,2HAT,2HAC 
     .          ,2HAP,2H/1,2H00,2H0 ,2H- ,2HHP,2H92,2H08,2H0A 
     .          ,2H R,2HEV,2H 2,2H02,2H6 ,17*2H  /
      DATA ICH/83/,LINPAG/60/,IUPT0/3/
C 
      IF(ISCRN.EQ.1)  GOTO 2000 
      IF(ISCRN.NE.0)  STOP 1000 
C 
C     ********************* 
C     * LISTING OPERATION * 
C     ********************* 
C 
C 
      CALL EXEC(2,LU,ILIS,20) 
C 
C-----IF LIST DEVICE IS NOT CRT, LOCK IT
C 
      CALL LCKLL(LU,LUPRT,500)
      CALL FTIME(IHEAD(25)) 
      IPAGE=0 
      ASSIGN 320 TO IRTN
      GOTO 900
320   K=NCRTH(11)+NCRTH(9)
      I=2HP 
      IF(NCRTH(6) .NE. 2HP1)  I=2HPD
      CALL JASC(NCRTH(8),JTEMP,1,6) 
      CALL TCVTA(JTEMP,6) 
      WRITE(LUPRT,100)I,JTEMP,K,(NCRTH(I),I=9,10) 
      WRITE(LUPRT,240)
      IF(NCRTH(13) .EQ. 0) GOTO 350 
      IF(NCRTH(13) .LT. 256)  GOTO 340
      WRITE(LUPRT,132)(NCRTH(I),I=13,17)
      GOTO 360
340   WRITE(LUPRT,130)NCRTH(13) 
      GOTO 360
350   WRITE(LUPRT,135)
360   LINB=LINB+7 
      IF(NCRTH(26) .EQ. 0)  GOTO 380
      J=27
      DO 372 I=1,NCRTH(26)
      CALL JASC(NCRTH(J+6),JTEMP,1,6) 
      CALL TCVTA(JTEMP,6) 
      CALL JASC(NCRTH(J+7),KTEMP,1,6) 
      CALL TCVTA(KTEMP,6) 
      WRITE(LUPRT,140)I,(NCRTH(K),K=J,J+5),JTEMP,KTEMP
      LINB=LINB+2 
372   J=J+15
      GOTO 390
380   WRITE(LUPRT,270)
      LINB=LINB+2 
390   WRITE(LUPRT,240)
      LINB=LINB+1 
      J=(NCRTH(3)-NCRTH(2))/2 
      WRITE(LUPRT,160) J
      LINB=LINB+2 
      J=J/7 
      K=NCRTH(2)
      IF(J.EQ.0) GOTO 401 
C 
C     PRINT 3070 LU'S 
C 
408   DO 400 I=1,J
      WRITE(LUPRT,170)(NCRTH(L),L=K,K+12,2) 
      DO 4000 LTMP=1,28 
4000  MTMPR(LTMP)=020040B 
      DO 4001 LTMP=K+1,K+13,2 
      IF(NCRTH(LTMP).EQ.10000)GO TO 4002
      CALL JASC(NCRTH(LTMP),SHOLD,1,4)
      GO TO 4003
4002  SHOLD=4H  NA
4003  CALL MOVEW(SHOLD,MTMPR(LTMP-K),2) 
4001  CONTINUE
      WRITE(LUPRT,180)(MTMPR(L),L=1,28) 
      LINB=LINB+2 
      K=K+14
400   CONTINUE
      IF(K.EQ.NCRTH(3)) GOTO 402
401   WRITE(LUPRT,170)(NCRTH(L),L=K,(NCRTH(3)-2),2) 
      DO 4050 LTMP=1,28 
4050  MTMPR(LTMP)=020040B 
      DO 4051 LTMP=K+1,(NCRTH(3)-2)+1,2 
      IF(NCRTH(LTMP).EQ.10000)GO TO 4052
      CALL JASC(NCRTH(LTMP),SHOLD,1,4)
      GO TO 4053
4052  SHOLD=4H  NA
4053  CALL MOVEW(SHOLD,MTMPR(LTMP-K),2) 
4051  CONTINUE
      WRITE(LUPRT,180)(MTMPR(L),L=1,28) 
      LINB=LINB+2 
402   J=(NCRTH(4)-NCRTH(3))/2 
      WRITE(LUPRT,240)
      LINB=LINB+1 
C 
C     USER'S MODULES PROGRAMS 
C 
      CALL BLANC(IBUF,350)
      CALL PUTCA(IBUF,1H&,3)
      CALL MOVCA(NCRTH,9,IBUF,4,4)
      CALL PUTCA(IBUF,1H%,13) 
      CALL MOVCA(NCRTH,9,IBUF,14,4) 
      CALL PUTCA(IBUF,1H>,23) 
      CALL MOVCA(NCRTH,9,IBUF,24,4) 
      IBUF(17)=2H%T 
      CALL MOVEW(NCRT5,IBUF(18),2)
      IBUF(22)=2H>T 
      CALL MOVEW(NCRT5,IBUF(23),2)
      CALL MOVEW(IBUF(17),IBUF(27),10)
      CALL PUTCA(IBUF,1HL,54) 
      CALL PUTCA(IBUF,1HL,64) 
      ICH=73
C-----SET UP IMAGE MODULE IF ANY
      IF(NCRTH(26) .EQ. 0)  GOTO 630
      J=53
      DO 620 I=1,NCRTH(26)
      CALL PUTCA(IBUF,1H%,ICH)
      CALL PUTCA(IBUF,1H>,ICH+10) 
      CALL MOVCA(NCRTH,J,IBUF,ICH+1,5)
      CALL MOVCA(NCRTH,J,IBUF,ICH+11,5) 
      ICH=ICH+20
620   J=J+30
630   IUPT=0
      ITUS=0
      J=NCRTH(4)
C 
C-----LOOP ON EACH USER PARTITION 
C 
640   I=NCRTH(J)
      K=J 
      PRINT = IUPT .GE. IUPT0 
      J=((I-J-3)/18)+1
      IF( I-K-3 .EQ. 18*(J-1) ) J=J-1 
      IF( .NOT. PRINT )  GOTO 650 
645   LINB=LINB+J+4 
      ASSIGN 645 TO IRTN
      IF( LINB .GE. LINPAG )  GOTO 900
      WRITE(LUPRT,240)
C-----WRITE PROGRAM NUMBER, SWAP OPTION ... 
      M=IUPT-IUPT0+1
      WRITE(LUPRT,200) M
C-----WRITE LOADER OPTION 
      WRITE(LUPRT,240)
650   CALL PUTCA(IBUF,1H%,20*IUPT+ICH)
      CALL PUTCA(IBUF,1H>,20*IUPT+ICH+10) 
      CALL MOVCA(NCRTH,9,IBUF,20*IUPT+ICH+1,4)
      CALL MOVCA(NCRTH,9,IBUF,20*IUPT+ICH+11,4) 
      CALL PUTCA(IBUF,1HA+IUPT*256,20*IUPT+ICH+5) 
      CALL PUTCA(IBUF,1HA+IUPT*256,20*IUPT+ICH+15)
      CALL ISUPB(IBUF((20*IUPT+ICH+1)/2),3) 
      CALL ISUPB(IBUF((20*IUPT+ICH+11)/2),3)
      K=K+3 
      LINE=0
690   L=K 
      CALL BLAN(NUMB,1,79)
      M=(2*(L-(K-3))/3) 
695   CALL MOVEW(6H  LB: ,NUMB(M),3)
      IF(IAND(NCRTH(L),100000B).NE.0) GOTO 698
      ITUS=ITUS+1 
      NUMB(M+2)=2H -
      CALL JASC(ITUS,NUMB(M+1),-1,3)
698   NUMB(M+3)=IAND(NCRTH(L),77777B) 
      CALL MOVEW(NCRTH(L+1),NUMB(M+4),2)
      L=L+3 
      M=M+6 
      IF(L.EQ.I) GOTO 699 
      IF(L.NE.K+18) GOTO 695
699   IF( PRINT )  CALL EXEC(2,LUPRT,NUMB,38) 
      K=K+18
      LINE=LINE+1 
      IF(LINE.NE.J) GOTO 690
      J=I 
      IUPT=IUPT+1 
      IF(J .NE. NCRTH+1) GOTO 640 
C 
C-----PRINT  " NO USER MODULES "  IF  # OF PART. = 2
C 
      IF( IUPT .NE. IUPT0 )  GOTO 710 
      WRITE(LUPRT,250)
      LINB=LINB+2 
C 
C-----PREPARE DCLOG MODULES FOR PRINTING
C 
710   IF(NCRTH(13).EQ.0) GO TO 720
      CALL MOVCA(6H%DCLOG,1,IBUF,20*IUPT+ICH,6) 
      CALL MOVCA(6H>DCLOG,1,IBUF,20*IUPT+ICH+10,6)
      IUPT=IUPT+1 
C 
C-----WRITE DIRECTORY (ALL FILES CREATED BY TMPGN)
C 
720   ASSIGN 720 TO IRTN
      K=1+(20*(IUPT+1)+ICH)/80
      LINB=LINB+5+K 
      IF( LINB .GE. LINPAG )  GOTO 900
      WRITE(LUPRT,230)
      J=1 
      DO 80 I=1,K 
      CALL EXEC(2,LUPRT,IBUF(J),39) 
80    J=J+40
C 
      CALL EXEC(3,1100B+LUPRT,-1) 
C 
C-----IF LIST DEVICE IS NOT CRT, UNLOCK THE LIST DEVICE 
C 
      IF(LU .NE. LUPRT)  CALL LURQ(0,LUPRT,1) 
      GO TO 3100
C 
C-----PRINT THE PAGE HEADER 
C 
900   IPAGE=IPAGE+1 
      CALL JASC(IPAGE,IHEAD,-7,4) 
      CALL EXEC(3,1100B+LUPRT,-1) 
      WRITE(LUPRT,110)IHEAD 
      LINB=4
      GOTO IRTN 
C 
C     FORMATS USED BY LISTG 
C 
110   FORMAT(40A2,2/, 
     .,5X"T R A N S A C T I O N   M O N I T O R   G E N E R A T O R"
     ."   L I S T" ,/)
100   FORMAT(/,3X,"TM"A2" IS GENERATED ON CARTRIDGE #"3A2,
     .2/,3X,"REQUIRES A MOTHER PARTITION OF"I4" K WORDS    (EMA=" 
     .I4,", MSEG="I3,")") 
120   FORMAT(/,3X,"NO USER'S MODULES")
130   FORMAT(/,3X,"LOGGING ON MAGNETIC TAPE LU :"I3)
132   FORMAT(/,3X,"LOGGING ON DISC FILE: "3A2," SC ="I6,
     ." ON CARTRIDGE #"I7)
135   FORMAT(/,3X,"NO LOGGING") 
140   FORMAT(/,3X,"DATA BASE #"I2", NAME: "3A2", LEVEL WORD: "3A2,
     .", SEC-COD: "3A2,", CR# ",3A2)
160   FORMAT(/,3X,"NUMBER OF DATA CAPTURE TERMINALS:  "I2)
170   FORMAT(/,3X,"LU :   "I2,6(7X,I2)) 
180   FORMAT(3X,  "TS#: "2A2,6(5X,2A2)) 
200   FORMAT(/,3X,"USER MODULES PROGRAM UNIT #: "I2,2X) 
220   FORMAT(3X,6(5A2,2X))
230   FORMAT(3/,3X"FILES CREATED BY TMPGN:",/)
240   FORMAT(5X)
250   FORMAT(/,3X,"NO USER MODULES.") 
270   FORMAT(/,3X,"NO DATA BASE") 
C 
C 
C 
C========================================================================== 
C 
C     ********************
C     *  LOAD OPERATION  *
C     ********************
C 
C 
2000  CALL TMGLD(IEND)
C-----IF LOAD OPERATION HAS FAILED, REPORT ERROR TO OPERATOR
      IF(IEND .LT. 0)  GOTO 3120
C 
C     LISTING OR LOADING PHASE IS FINISH, 
C     WRITE MESSAGE ON CRT IF NEEDED & EXIT 
C 
3100  IF(LU .NE. LUPRT) GOTO 3300 
      IEND=3
3120  CALL TMGSC(0,0,0,IEND,IJOB) 
C 
C-----ACKNOWLEDGMENT NOT NEEDED, TERMINATE TMPGN
C 
3300  CALL TMGSC(0,0,0,2) 
C 
C     DUMMY CALL TO MAIN  !!
C 
      CALL TMPGN
      END 
      END$
                                                                                    