FTN4
      PROGRAM TMPG1(5),92903-16453 REV.1913  790212 
C 
C 
C     NAME: TMPG1 
C     SOURCE: &TMPG1    92903-18453 
C     BINARY %TMPG1     92903-16453 
C 
C     PGMR: DANIEL POT/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         *  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 
C-----LABEL COMMON # 1  GENERAL INFORMATION 
C 
      COMMON /TMGC1/LU,LUPRT,LUOUT,ISYTP,IRQ(3),IJOB
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IDUM0(7),NCRTH(1) 
C 
C 
      DIMENSION IBUF(350),NUMB(40),ILIS(20),IHEAD(40) 
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,2H90,2H3A 
     .          ,2H R,2HEV,2H 1,2H91,2H3 ,17*2H  /
      DATA ICH/83/,LINPAG/60/,IUPT0/3/
C 
      IF(IRQ.EQ.1)  GOTO 2000 
      IF(IRQ.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
      WRITE(LUPRT,100)I,NCRTH(8),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)
      WRITE(LUPRT,140)I,(NCRTH(K),K=J,J+6)
      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) 
      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) 
      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 720 
      WRITE(LUPRT,250)
      LINB=LINB+2 
C 
C-----WRITE DIRECTORY (ALL FILES CREATED BY TMSGN)
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 #"I6, 
     .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," ON CARTRIDGE #"I6,
     ." SC ="I7)
135   FORMAT(/,3X,"NO LOGGING") 
140   FORMAT(/,3X,"DATA BASE #"I2", NAME: "3A2", LEVEL ACCESS WORD: "3A2, 
     .", SEC. CODE: "I6)
160   FORMAT(/,3X,"NUMBER OF DATA CAPTURE TERMINALS:  "I2)
170   FORMAT(/,3X,"LU :   "I2,6(7X,I2)) 
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$
                                  